From 1fe1ed7b3ca362faa292e2694c7556b2021b9025 Mon Sep 17 00:00:00 2001 From: Jim Schaff Date: Fri, 23 Oct 2026 15:12:08 -0400 Subject: [PATCH 1/3] Bundle BioNetGen 2.9.3 to generate rule-based reaction networks; version 0.0.22 VCell expands a rule-based application's reaction rules into a reaction network with BioNetGen (perl /bionetgen/BNG2.pl), which libvcell lacked: such math could not be generated (vcml_to_ode_input fell back to the stored math; vcml_to_vcml and the others failed). - libvcell/vcell_install/bionetgen/: the Perl part of BioNetGen 2.9.3 (MIT): BNG2.pl and Perl2/, copied unchanged from the official release (README records the source and sha256); network generation does not use its compiled simulators, so bin/ is left out. Pre-commit excludes it. - The Python package sets LIBVCELL_VCELL_INSTALL_DIR to it, and BioNetGenSupport.configure(), first in every model-building method, makes it vcell.installDir (each call runs in a fresh isolate). - vcml_to_ode_input regenerates a rule-based application with it and falls back to the stored math only if that fails (no perl on the PATH, a BioNetGen timeout), naming the reason in its message. - build.py and the local build script record with the variable set, so native-image covers the BioNetGen path. Checked against VCell's own BioNetGen 2.3.0 (vcell_submodule/bionetgen) on the 109 rule-based models with ODE simulations in a 2,730-model VCell corpus: 103 give byte-identical solver input with either version; the other 6 fail identically with both (model errors, two BioNetGen timeouts). Co-Authored-By: Claude Opus 5.5 --- .pre-commit-config.yaml | 2 + CLAUDE.md | 11 + build.py | 3 + libvcell/_internal/native_utils.py | 14 + libvcell/vcell_install/bionetgen/BNG2.pl | 252 + libvcell/vcell_install/bionetgen/CREDITS.txt | 88 + libvcell/vcell_install/bionetgen/LICENSE | 21 + .../bionetgen/Perl2/Aux2/MakeBin.pl | 66 + .../bionetgen/Perl2/Aux2/bnglstat.pl | 12 + .../bionetgen/Perl2/Aux2/count_blocks.pl | 26 + .../bionetgen/Perl2/Aux2/count_lines.pl | 51 + .../bionetgen/Perl2/Aux2/countdown.pl | 6 + .../bionetgen/Perl2/Aux2/diff_cdat.pl | 120 + .../bionetgen/Perl2/Aux2/express.pl | 164 + .../bionetgen/Perl2/Aux2/express_main.pl | 114 + .../bionetgen/Perl2/Aux2/group_size.pl | 17 + .../bionetgen/Perl2/Aux2/runBNG.pl | 135 + .../bionetgen/Perl2/Aux2/test.pl | 21 + .../bionetgen/Perl2/Aux2/test_compartment.pl | 56 + .../bionetgen/Perl2/Aux2/test_molorder.pl | 20 + .../bionetgen/Perl2/Aux2/test_redirect.pl | 19 + .../bionetgen/Perl2/Aux2/test_sub.pl | 13 + .../bionetgen/Perl2/BNGAction.pm | 2110 ++++++++ .../bionetgen/Perl2/BNGMessages.pm | 46 + .../vcell_install/bionetgen/Perl2/BNGModel.pm | 2643 +++++++++ .../bionetgen/Perl2/BNGOptions.pm | 66 + .../bionetgen/Perl2/BNGOutput.pm | 4770 +++++++++++++++++ .../vcell_install/bionetgen/Perl2/BNGUtils.pm | 598 +++ .../Perl2/Boolean2BNGL/ABC_example.txt | 7 + .../Perl2/Boolean2BNGL/Boolean2BNGL.pl | 222 + .../Boolean2BNGL/Tcell_model_Nov2013_LAH.txt | 110 + .../Boolean2BNGL/Tcell_model_Oct2013.txt | 108 + .../Perl2/Boolean2BNGL/Tcell_model_v16.txt | 20 + .../vcell_install/bionetgen/Perl2/Cache.pm | 93 + .../bionetgen/Perl2/CartesianProduct.pm | 309 ++ .../bionetgen/Perl2/Compartment.pm | 449 ++ .../bionetgen/Perl2/CompartmentList.pm | 240 + .../bionetgen/Perl2/Component.pm | 648 +++ .../bionetgen/Perl2/ComponentType.pm | 261 + .../vcell_install/bionetgen/Perl2/Console.pm | 239 + .../bionetgen/Perl2/EnergyPattern.pm | 262 + .../bionetgen/Perl2/Expression.pm | 2240 ++++++++ .../vcell_install/bionetgen/Perl2/Function.pm | 566 ++ .../vcell_install/bionetgen/Perl2/HNauty.pm | 1010 ++++ .../bionetgen/Perl2/MacroBNG2.pl | 27 + .../bionetgen/Perl2/MacroBNGModel.pm | 2087 ++++++++ libvcell/vcell_install/bionetgen/Perl2/Map.pm | 371 ++ .../bionetgen/Perl2/ModelWrapper.pm | 148 + .../vcell_install/bionetgen/Perl2/Molecule.pm | 773 +++ .../bionetgen/Perl2/MoleculeType.pm | 585 ++ .../bionetgen/Perl2/MoleculeTypesList.pm | 402 ++ .../bionetgen/Perl2/Observable.pm | 756 +++ .../vcell_install/bionetgen/Perl2/Param.pm | 395 ++ .../bionetgen/Perl2/ParamList.pm | 1200 +++++ .../bionetgen/Perl2/Population.pm | 98 + .../bionetgen/Perl2/PopulationList.pm | 120 + .../vcell_install/bionetgen/Perl2/RateLaw.pm | 1395 +++++ .../bionetgen/Perl2/RefineRule.pm | 769 +++ libvcell/vcell_install/bionetgen/Perl2/Rxn.pm | 417 ++ .../vcell_install/bionetgen/Perl2/RxnList.pm | 550 ++ .../vcell_install/bionetgen/Perl2/RxnRule.pm | 4280 +++++++++++++++ .../bionetgen/Perl2/SBMLMultiAux.pm | 471 ++ .../vcell_install/bionetgen/Perl2/Species.pm | 242 + .../bionetgen/Perl2/SpeciesGraph.pm | 3653 +++++++++++++ .../bionetgen/Perl2/SpeciesList.pm | 820 +++ .../Perl2/Visualization/ContactMap.pm | 156 + .../bionetgen/Perl2/Visualization/GML.pm | 2111 ++++++++ .../Perl2/Visualization/NetworkGraph.pm | 981 ++++ .../Perl2/Visualization/ProcessGraph.pm | 584 ++ .../bionetgen/Perl2/Visualization/README | 34 + .../bionetgen/Perl2/Visualization/RINF.pm | 119 + .../Perl2/Visualization/StructureGraph.pm | 661 +++ .../Perl2/Visualization/VisOptParse.pm | 175 + .../bionetgen/Perl2/Visualization/Viz.pm | 1813 +++++++ .../bionetgen/Perl2/Visualization/analyze.pl | 669 +++ .../bionetgen/Perl2/Visualization/readGML.pl | 192 + .../Perl2/Visualization/visualize.pl | 270 + .../bionetgen/Perl2/XML/TreePP.pm | 1331 +++++ .../bionetgen/Perl2/XMLReader.pm | 67 + .../vcell_install/bionetgen/Perl2/auto_hpp.pl | 235 + .../vcell_install/bionetgen/Perl2/diff_net.pl | 443 ++ .../bionetgen/Perl2/sample_vars_2.pl | 571 ++ .../vcell_install/bionetgen/Perl2/scan_var.pl | 398 ++ .../bionetgen/Perl2/test_cartesianproduct.pl | 75 + .../vcell_install/bionetgen/Perl2/verify.pl | 178 + libvcell/vcell_install/bionetgen/README.md | 19 + libvcell/vcell_install/bionetgen/VERSION | 1 + pyproject.toml | 6 +- scripts/local_build_native.sh | 5 +- tests/test_libvcell.py | 19 +- .../org/vcell/libvcell/BioNetGenSupport.java | 41 + .../java/org/vcell/libvcell/Entrypoints.java | 8 +- .../java/org/vcell/libvcell/ModelUtils.java | 4 + .../java/org/vcell/libvcell/SolverUtils.java | 56 +- .../vcell/libvcell/SolverEntrypointsTest.java | 20 +- 95 files changed, 49014 insertions(+), 35 deletions(-) create mode 100755 libvcell/vcell_install/bionetgen/BNG2.pl create mode 100644 libvcell/vcell_install/bionetgen/CREDITS.txt create mode 100644 libvcell/vcell_install/bionetgen/LICENSE create mode 100755 libvcell/vcell_install/bionetgen/Perl2/Aux2/MakeBin.pl create mode 100755 libvcell/vcell_install/bionetgen/Perl2/Aux2/bnglstat.pl create mode 100755 libvcell/vcell_install/bionetgen/Perl2/Aux2/count_blocks.pl create mode 100755 libvcell/vcell_install/bionetgen/Perl2/Aux2/count_lines.pl create mode 100755 libvcell/vcell_install/bionetgen/Perl2/Aux2/countdown.pl create mode 100755 libvcell/vcell_install/bionetgen/Perl2/Aux2/diff_cdat.pl create mode 100755 libvcell/vcell_install/bionetgen/Perl2/Aux2/express.pl create mode 100755 libvcell/vcell_install/bionetgen/Perl2/Aux2/express_main.pl create mode 100755 libvcell/vcell_install/bionetgen/Perl2/Aux2/group_size.pl create mode 100755 libvcell/vcell_install/bionetgen/Perl2/Aux2/runBNG.pl create mode 100755 libvcell/vcell_install/bionetgen/Perl2/Aux2/test.pl create mode 100755 libvcell/vcell_install/bionetgen/Perl2/Aux2/test_compartment.pl create mode 100755 libvcell/vcell_install/bionetgen/Perl2/Aux2/test_molorder.pl create mode 100755 libvcell/vcell_install/bionetgen/Perl2/Aux2/test_redirect.pl create mode 100755 libvcell/vcell_install/bionetgen/Perl2/Aux2/test_sub.pl create mode 100644 libvcell/vcell_install/bionetgen/Perl2/BNGAction.pm create mode 100644 libvcell/vcell_install/bionetgen/Perl2/BNGMessages.pm create mode 100644 libvcell/vcell_install/bionetgen/Perl2/BNGModel.pm create mode 100644 libvcell/vcell_install/bionetgen/Perl2/BNGOptions.pm create mode 100644 libvcell/vcell_install/bionetgen/Perl2/BNGOutput.pm create mode 100644 libvcell/vcell_install/bionetgen/Perl2/BNGUtils.pm create mode 100644 libvcell/vcell_install/bionetgen/Perl2/Boolean2BNGL/ABC_example.txt create mode 100644 libvcell/vcell_install/bionetgen/Perl2/Boolean2BNGL/Boolean2BNGL.pl create mode 100644 libvcell/vcell_install/bionetgen/Perl2/Boolean2BNGL/Tcell_model_Nov2013_LAH.txt create mode 100644 libvcell/vcell_install/bionetgen/Perl2/Boolean2BNGL/Tcell_model_Oct2013.txt create mode 100644 libvcell/vcell_install/bionetgen/Perl2/Boolean2BNGL/Tcell_model_v16.txt create mode 100644 libvcell/vcell_install/bionetgen/Perl2/Cache.pm create mode 100644 libvcell/vcell_install/bionetgen/Perl2/CartesianProduct.pm create mode 100644 libvcell/vcell_install/bionetgen/Perl2/Compartment.pm create mode 100644 libvcell/vcell_install/bionetgen/Perl2/CompartmentList.pm create mode 100644 libvcell/vcell_install/bionetgen/Perl2/Component.pm create mode 100644 libvcell/vcell_install/bionetgen/Perl2/ComponentType.pm create mode 100644 libvcell/vcell_install/bionetgen/Perl2/Console.pm create mode 100644 libvcell/vcell_install/bionetgen/Perl2/EnergyPattern.pm create mode 100644 libvcell/vcell_install/bionetgen/Perl2/Expression.pm create mode 100644 libvcell/vcell_install/bionetgen/Perl2/Function.pm create mode 100644 libvcell/vcell_install/bionetgen/Perl2/HNauty.pm create mode 100755 libvcell/vcell_install/bionetgen/Perl2/MacroBNG2.pl create mode 100644 libvcell/vcell_install/bionetgen/Perl2/MacroBNGModel.pm create mode 100644 libvcell/vcell_install/bionetgen/Perl2/Map.pm create mode 100644 libvcell/vcell_install/bionetgen/Perl2/ModelWrapper.pm create mode 100644 libvcell/vcell_install/bionetgen/Perl2/Molecule.pm create mode 100644 libvcell/vcell_install/bionetgen/Perl2/MoleculeType.pm create mode 100644 libvcell/vcell_install/bionetgen/Perl2/MoleculeTypesList.pm create mode 100644 libvcell/vcell_install/bionetgen/Perl2/Observable.pm create mode 100644 libvcell/vcell_install/bionetgen/Perl2/Param.pm create mode 100644 libvcell/vcell_install/bionetgen/Perl2/ParamList.pm create mode 100644 libvcell/vcell_install/bionetgen/Perl2/Population.pm create mode 100644 libvcell/vcell_install/bionetgen/Perl2/PopulationList.pm create mode 100644 libvcell/vcell_install/bionetgen/Perl2/RateLaw.pm create mode 100644 libvcell/vcell_install/bionetgen/Perl2/RefineRule.pm create mode 100644 libvcell/vcell_install/bionetgen/Perl2/Rxn.pm create mode 100644 libvcell/vcell_install/bionetgen/Perl2/RxnList.pm create mode 100644 libvcell/vcell_install/bionetgen/Perl2/RxnRule.pm create mode 100644 libvcell/vcell_install/bionetgen/Perl2/SBMLMultiAux.pm create mode 100644 libvcell/vcell_install/bionetgen/Perl2/Species.pm create mode 100644 libvcell/vcell_install/bionetgen/Perl2/SpeciesGraph.pm create mode 100644 libvcell/vcell_install/bionetgen/Perl2/SpeciesList.pm create mode 100644 libvcell/vcell_install/bionetgen/Perl2/Visualization/ContactMap.pm create mode 100644 libvcell/vcell_install/bionetgen/Perl2/Visualization/GML.pm create mode 100644 libvcell/vcell_install/bionetgen/Perl2/Visualization/NetworkGraph.pm create mode 100644 libvcell/vcell_install/bionetgen/Perl2/Visualization/ProcessGraph.pm create mode 100644 libvcell/vcell_install/bionetgen/Perl2/Visualization/README create mode 100644 libvcell/vcell_install/bionetgen/Perl2/Visualization/RINF.pm create mode 100644 libvcell/vcell_install/bionetgen/Perl2/Visualization/StructureGraph.pm create mode 100644 libvcell/vcell_install/bionetgen/Perl2/Visualization/VisOptParse.pm create mode 100644 libvcell/vcell_install/bionetgen/Perl2/Visualization/Viz.pm create mode 100644 libvcell/vcell_install/bionetgen/Perl2/Visualization/analyze.pl create mode 100644 libvcell/vcell_install/bionetgen/Perl2/Visualization/readGML.pl create mode 100755 libvcell/vcell_install/bionetgen/Perl2/Visualization/visualize.pl create mode 100644 libvcell/vcell_install/bionetgen/Perl2/XML/TreePP.pm create mode 100644 libvcell/vcell_install/bionetgen/Perl2/XMLReader.pm create mode 100755 libvcell/vcell_install/bionetgen/Perl2/auto_hpp.pl create mode 100755 libvcell/vcell_install/bionetgen/Perl2/diff_net.pl create mode 100644 libvcell/vcell_install/bionetgen/Perl2/sample_vars_2.pl create mode 100755 libvcell/vcell_install/bionetgen/Perl2/scan_var.pl create mode 100755 libvcell/vcell_install/bionetgen/Perl2/test_cartesianproduct.pl create mode 100755 libvcell/vcell_install/bionetgen/Perl2/verify.pl create mode 100644 libvcell/vcell_install/bionetgen/README.md create mode 100644 libvcell/vcell_install/bionetgen/VERSION create mode 100644 vcell-native/src/main/java/org/vcell/libvcell/BioNetGenSupport.java diff --git a/.pre-commit-config.yaml b/.pre-commit-config.yaml index 1f33da2..bd89556 100644 --- a/.pre-commit-config.yaml +++ b/.pre-commit-config.yaml @@ -1,3 +1,5 @@ +# vendored BioNetGen, kept byte-identical to its release +exclude: ^libvcell/vcell_install/bionetgen/ repos: - repo: https://github.com/pre-commit/pre-commit-hooks rev: "v4.4.0" diff --git a/CLAUDE.md b/CLAUDE.md index 91f750f..182e21b 100644 --- a/CLAUDE.md +++ b/CLAUDE.md @@ -82,6 +82,17 @@ Pre-commit hooks run ruff (lint + format) and prettier automatically. Linux wheels are built inside the `docker/Dockerfile_manylinux_*` images (manylinux 2_28 and 2_34, for both `aarch64` and `x86_64`), which provide the GraalVM toolchain needed for native compilation in CI. +### Bundled BioNetGen + +`libvcell/vcell_install/bionetgen/` is the Perl part of BioNetGen 2.9.3 (MIT; `BNG2.pl` and `Perl2/`, copied +unchanged from the official release; see its `README.md`, and keep it byte-identical: pre-commit excludes it). VCell +runs `perl /bionetgen/BNG2.pl` to expand a rule-based application's reaction rules into a network +when it generates the math. The Python package sets `LIBVCELL_VCELL_INSTALL_DIR` to `libvcell/vcell_install` +(`_internal/native_utils.py`), and `BioNetGenSupport.configure()`, called at the start of every model-building method, +turns it into `vcell.installDir` (each call runs in a fresh isolate). Without `perl` or BioNetGen, +`vcml_to_ode_input` falls back to the document's stored math and says why in its message. The recorder run in +`build.py` sets the variable too, so native-image records the BioNetGen path. + ### Key dependencies - `vcell_submodule/` — Git submodule pointing to the full VCell Java repository (provides vcell-core). After cloning or pulling a submodule pointer bump, run `git submodule update --init --recursive` — git does NOT auto-update the submodule working tree, so it can sit at an older commit than the recorded pointer (shows as `M vcell_submodule` in `git status`). A stale checkout causes `vcell-native` to fail compiling against vcell-core. To make vcell-core/math available for a local `vcell-native` build, install them into `.m2` first: `mvn -DskipTests clean install -f vcell_submodule` (or run the full `scripts/local_build_native.sh`). diff --git a/build.py b/build.py index afe1bfa..e4adc13 100644 --- a/build.py +++ b/build.py @@ -1,3 +1,4 @@ +import os import shutil import subprocess import sys @@ -61,6 +62,8 @@ def main() -> None: "unnamed_spatialGeom " "target/sbml-input", cwd=vcell_native_dir, + # the bundled BioNetGen, so the recording covers generating a rule-based reaction network (perl BNG2.pl) + env={**os.environ, "LIBVCELL_VCELL_INSTALL_DIR": str(root_dir / "libvcell" / "vcell_install")}, ) # Build vcell-native as native shared object library diff --git a/libvcell/_internal/native_utils.py b/libvcell/_internal/native_utils.py index 7a614a4..5a42f50 100644 --- a/libvcell/_internal/native_utils.py +++ b/libvcell/_internal/native_utils.py @@ -1,15 +1,29 @@ import ctypes +import os import platform from _ctypes import byref from importlib.resources import files import libvcell +#: The environment variable the native library reads to find VCell's resources (org.vcell.libvcell.BioNetGenSupport). +VCELL_INSTALL_DIR_ENV = "LIBVCELL_VCELL_INSTALL_DIR" + + +def _use_bundled_bionetgen() -> None: + """Point the native library at the BioNetGen this package bundles (``vcell_install/bionetgen/BNG2.pl``), which + VCell runs with ``perl`` to generate a rule-based application's reaction network. A value already in the + environment wins.""" + install_dir = files(libvcell).joinpath("vcell_install") + if install_dir.joinpath("bionetgen", "BNG2.pl").is_file(): + os.environ.setdefault(VCELL_INSTALL_DIR_ENV, str(install_dir)) + class VCellNativeLibraryLoader: lib: ctypes.CDLL def __init__(self) -> None: + _use_bundled_bionetgen() self.lib = self._load_library() self._define_entry_points() diff --git a/libvcell/vcell_install/bionetgen/BNG2.pl b/libvcell/vcell_install/bionetgen/BNG2.pl new file mode 100755 index 0000000..2b1f5f1 --- /dev/null +++ b/libvcell/vcell_install/bionetgen/BNG2.pl @@ -0,0 +1,252 @@ +#!/usr/bin/perl + +# BioNetGen : rule-based modeling language and simulation platform +# +# Copyright (C) 2006,2009,2012 by +# +# James R. Faeder (faeder at pitt dot edu) +# Justin S. Hogg (justinshogg at gmail dot com) +# Leonard A. Harris (lh64 at cornell dot com) +# John A. P. Sekar (johnarul dot sekar at gmail dot com) +# Jose Juan Tapia +# Arshi Arora +# +# 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 3 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, see . + +# pragmas +use strict; +use warnings; + +# Perl Modules +use Config; +use File::Spec; +use FindBin; +use Getopt::Long; +use IO::Handle; + +# get Perl2 Module directory: look for environment variables BNGPATH or BioNetGenRoot. +# If neither are defined, use RealBin module +use lib File::Spec->catdir( ( exists $ENV{'BNGPATH'} + ? $ENV{'BNGPATH'} + : ( exists $ENV{'BioNetGenRoot'} + ? $ENV{'BioNetGenRoot'} + : $FindBin::RealBin + ) + ), + 'Perl2' + ); +# BNG Modules +use BNGUtils; +use BNGModel; +use Console; + + +# Set up Signal Handlers.. +# Define global variable to store PID of child process. +$::CHILD_PID = undef; +# Get signal names +my $i = 0; +my %SIGNO=(); +defined($Config{sig_name}) or die "No signals defined"; +foreach my $signame ( split " ", $Config{sig_name} ) +{ + $SIGNO{$signame} = $i; + $i++; +} +# TERM signal handler: make sure any child processes are shutdown before termination +$SIG{'TERM'} = sub +{ + if (defined $::CHILD_PID) + { # kill off child process + print "\n>>> relaying TERM signal to child with PID: ", $::CHILD_PID, " <<<\n"; + kill $SIGNO{"TERM"}, $::CHILD_PID; + } + exit_error( sprintf "BioNetGen received TERM signal (%d)", $SIGNO{"TERM"} ); +}; +# INT signal handler: make sure any child processes are shutdown before termination +$SIG{'INT'} = sub +{ + if (defined $::CHILD_PID) + { # kill off child process + print "\n>>> relaying INT signal to child with PID: ", $::CHILD_PID, " <<<\n"; + kill $SIGNO{"INT"}, $::CHILD_PID; + } + exit_error( sprintf "BioNetGen received TERM signal (%d)", $SIGNO{"INT"} ); +}; + + + +# Defaults params for File mode +my %default_args = ( 'write_xml' => 0, 'write_mfile' => 0, + 'write_SBML' => 0, 'generate_network' => 0, + 'skip_actions' => 0, 'action_skip_warn' => 1, + 'logging' => 0, 'no_exec' => 0, + 'allow_perl' => 0, 'no_nfsim' => 0, + 'output_dir' => File::Spec->curdir(), + 'no_atomizer' => 0, + 'write_autos' => 0, 'write_SBMLmulti' => 0 + ); +# Default params for Console mode +my %default_args_console = ( 'write_xml' => 0, 'write_mfile' => 0, + 'write_SBML' => 0, 'generate_network' => 0, + 'skip_actions' => 1, 'action_skip_warn' => 1, + 'logging' => 0, 'no_exec' => 0, + 'allow_perl' => 0, 'no_nfsim' => 0, + 'output_dir' => File::Spec->curdir(), + 'no_atomizer' => 0, 'write_autos' => 0, + 'write_SBMLmulti' => 0 + ); + + +# variables to contain user args +my $console = 0; +my $findbin = ''; +my $help = 0; +my $version = 0; +my %user_args = ( 'console' => \$console, + 'findbin' => \$findbin, + 'help' => \$help, + 'version' => \$version + ); + +# parse command line arguments +GetOptions( \%user_args, + 'help|h', + 'version|v', + 'console', + 'findbin=s', + 'skip_actions|check', + 'no_nfsim|no-nfsim', + 'no_atomizer|no-atomizer', + 'output_dir|outdir=s', + 'logging|log', + 'generate_network|netgen', + 'write_SBML|sbml', + 'write_mfile|mfile', + 'write_xml|xml', + 'write_SBMLmulti|sbmlmulti', + 'write_autos|autos' + ) +or die "Error in command line arguments (try: BNG2.pl --help)"; + +# display help if requested +if ($help) +{ + display_help(); + exit(0); +} + +# display version info +if ($version) +{ + printf "BioNetGen version %s\n", BNGversion(); + exit(0); +} + +# try to find binary +if (not( $findbin eq '')) +{ + # exit with value 0 if binary is found, 1 otherwise + exit( BNGModel::findExec($findbin) ? 0 : 1 ); +} + + + +if ( $console ) +{ + # get arguments + my %args = (); + while ( my ($opt,$val) = each %default_args_console ) + { + $args{$opt} = exists $user_args{$opt} ? $user_args{$opt} : $val; + } + + # check if output directory exists and is writable + unless ( -d $args{output_dir} ) + { send_warning( sprintf "Default output directory '%s' is not a directory.", $args{output_dir}); } + unless ( -w $args{output_dir} ) + { send_warning( sprintf "Not able to write to default output directory '%s'.", $args{output_dir}); } + + # start console + my $err = BNGconsole( \%args ); + exit_error($err) if ($err); +} +else +{ + unless (@ARGV) + { display_help(); } + + # get arguments + my %args = (); + while ( my ($opt,$val) = each %default_args ) + { + $args{$opt} = exists $user_args{$opt} ? $user_args{$opt} : $val; + } + + # check if output directory exists and is writable + unless ( -d $args{output_dir} ) + { send_warning( sprintf "Default output directory '%s' is not a directory.", $args{output_dir}); } + unless ( -w $args{output_dir} ) + { send_warning( sprintf "Not able to write to default output directory '%s'.", $args{output_dir}); } + + # Process any files + while ( my $file = shift @ARGV ) + { + # create BNGModel object + my $model = BNGModel->new(); + $model->initialize(); + $BNGModel::GLOBAL_MODEL = $model; + + # set file argument + $args{'file'} = $file; + + # read and process Model file + my $err = $model->readFile( \%args ); + exit_error($err) if ($err); + + # undefine model + %$model = (); undef %$model; + $BNGModel::GLOBAL_MODEL = undef; + } +} + +# all done! +exit(0); + + + + +# Display Help Menu +sub display_help +{ + printf "\nBioNetGen version %s\n", BNGversion(); + print "--------------------------------------------------/ HELP MENU /-----\n" + ." SYNOPSIS \n" + ." process MODEL: BNG2.pl [OPTION]... MODEL... \n" + ." start BNG console: BNG2.pl --console \n" + ." display help: BNG2.pl -h \n" + ." display version: BNG2.pl -v \n" + ." \n" + ." OPTIONS \n" + ." --log write log to file MODEL.log (default is STDOUT) \n" + ." --xml write XML output after processing MODEL \n" + ." --mfile write MATLAB M-file output after processing MODEL\n" + ." --sbml write SBML output after processing MODEL \n" + ." --check read MODEL, but do not execute actions \n" + ." --outdir PATH change default output path \n" + ." \n" + ." For more information, visit bionetgen.org \n" + ."--------------------------------------------------------------------\n"; +} + diff --git a/libvcell/vcell_install/bionetgen/CREDITS.txt b/libvcell/vcell_install/bionetgen/CREDITS.txt new file mode 100644 index 0000000..a276e7e --- /dev/null +++ b/libvcell/vcell_install/bionetgen/CREDITS.txt @@ -0,0 +1,88 @@ +The following people have contributed to BioNetGen code development: + +Michael L. Blinov + * Original author. + * Testing and development of new ideas. + * Developed interface to Virtual Cell. + +James R. Faeder + * Primary BioNetGen developer since version 1.0. + * Testing and development of new ideas. + * Code maintainer. + * Current project co-PI. + +William S. Hlavacek + * Driving force in the development. + * Testing and development of new ideas. + * Current project PI. + +Byron Goldstein + * Pioneered concept of signaling models based on multivalent interactions. + * Original project PI. + +Justin Hogg + * Compartmental BNGL (cBNGL). + * General maintenance. + +Leonard Harris + * Network3 development: global functions, accelerated stochastics (PLA) + +Ilya Korsunsky + * Initial deployment of global functions for Network3. + +John Sekar + * Visualization - rule visualization, regulatory graphs. + +Jose Juan Tapia + * BioNetGen grammars development and implementation + * SBML2BNGL developer + +Adam Smith + * RuleBender developer + +Michael Sneddon + * Author and maintainer of NFsim. + * Contributor to BNGXML and maintainer of BNG-NFsim interface. + +Thierry Emonet + * NFsim PI + +Jeremy Kozdon + * Code for use of sparse Jacobian in CVODE calls, which greatly accelerates +ODE integration for large networks (sparse=>1 option). + +Nathan Lemons + * HNauty code for canonical labeling of hierarchical graphs, which is (optionally) used +in network generation,. + +Matthew Fricke + * Primary author of RuleBuilder. + +Leigh Fanning + * Contributor to RuleBuilder development. + * Developed RuleBuilder help system. + +Robert Seletsky + * Testing of BioNetGen and RuleBuilder. + +Sarah Faeder + * Contributor of PhiBPlot. + * Testing and bug fixes for RuleBuilder. + +Nikolay Borisov + * Primary developer of Macro module. + * Testing of BioNetGen. + +Mikhail Kravchenko + * Implementation of macro code. + * Streamlining of BioNetGen interface. + +Alexander S. Chistopolsky + * Developer of macro algorithm + +Marc Birtwistle + * Contributor of parameter sensitivity code. + +Dipak Barua + * BNGL to MDL converter. + diff --git a/libvcell/vcell_install/bionetgen/LICENSE b/libvcell/vcell_install/bionetgen/LICENSE new file mode 100644 index 0000000..fbd0e35 --- /dev/null +++ b/libvcell/vcell_install/bionetgen/LICENSE @@ -0,0 +1,21 @@ +MIT License + +Copyright (c) 2024 James R. Faeder + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +SOFTWARE. diff --git a/libvcell/vcell_install/bionetgen/Perl2/Aux2/MakeBin.pl b/libvcell/vcell_install/bionetgen/Perl2/Aux2/MakeBin.pl new file mode 100755 index 0000000..4f3c1d4 --- /dev/null +++ b/libvcell/vcell_install/bionetgen/Perl2/Aux2/MakeBin.pl @@ -0,0 +1,66 @@ +#!/usr/bin/perl + +$bindir="../PerlBin"; + +@scripts= qw( +BNG2.pl +); + +@modules= qw( +BNGModel.pm +BNGUtils.pm +Component.pm +ComponentType.pm +Map.pm +Molecule.pm +MoleculeType.pm +MoleculeTypesList.pm +Observable.pm +Param.pm +ParamList.pm +RateLaw.pm +Rxn.pm +RxnList.pm +RxnRule.pm +Species.pm +SpeciesGraph.pm +SpeciesList.pm +); + +#print join(" ", @modules),"\n"; +print "Compiling modules.\n"; +$n_compiled=0; +for my $module (@modules){ + $modfile= "${bindir}/$module"; + if (!-e $modfile || (-M $module < -M $modfile)){ + print "Compiling module $module\n"; + # Makes byte compiled version of each module + print `perlcc -B -o ${bindir}/$module $module`; + ++$n_compiled; + } else { + print "Module $module up to date\n"; + } +} +if (!$n_compiled){ + print "All modules up to date.\n"; +} + +print "Compiling scripts.\n"; +$n_compiled=0; +for my $script (@scripts){ + $sfile= "${bindir}/$script"; + $sfile=~ s/[.]pl$//; + if (!-e $sfile || (-M $script < -M $sfile)){ + print "Compiling script $script\n"; + # Makes byte compiled version of each module + print `perlcc -B -o ${bindir}/$sfile $script`; + ++$n_compiled; + } else { + print "Script $script up to date\n"; + } +} +if (!$n_compiled){ + print "All scripts up to date.\n"; +} + + diff --git a/libvcell/vcell_install/bionetgen/Perl2/Aux2/bnglstat.pl b/libvcell/vcell_install/bionetgen/Perl2/Aux2/bnglstat.pl new file mode 100755 index 0000000..fcf76ce --- /dev/null +++ b/libvcell/vcell_install/bionetgen/Perl2/Aux2/bnglstat.pl @@ -0,0 +1,12 @@ +#!/usr/bin/perl + +use FindBin; +use lib $FindBin::Bin; +use BNGModel; +use BNGUtils; + +while (@ARGV){ + my $file= shift(@ARGV); + my $model= BNGModel->new(); + if ($err=$model->readFile($file,{no_exec=>1})){exit_error($err);} +} diff --git a/libvcell/vcell_install/bionetgen/Perl2/Aux2/count_blocks.pl b/libvcell/vcell_install/bionetgen/Perl2/Aux2/count_blocks.pl new file mode 100755 index 0000000..09f36a0 --- /dev/null +++ b/libvcell/vcell_install/bionetgen/Perl2/Aux2/count_blocks.pl @@ -0,0 +1,26 @@ +#!/usr/bin/perl + +for $file (@ARGV){ + open(FILE,$file) || die "Couldn't open $file: $!\n"; + print "$file:\n"; + while(){ + if (/^s*begin\s+(\S.*)$/){ + $bname= $1; + $bname=~ s/\s*$//; + $nentry=0; + while(){ + if (/^\s*end\s+(\S.*)$/){ + my $ename= $1; + $ename=~ s/\s*$//; + if ($bname ne $ename){ + die "end $ename not compatible with $bname\n"; + } + last; + } + ++$nentry; + } + printf "%7d %s\n", $nentry, $bname; + } + } + close(FILE); +} diff --git a/libvcell/vcell_install/bionetgen/Perl2/Aux2/count_lines.pl b/libvcell/vcell_install/bionetgen/Perl2/Aux2/count_lines.pl new file mode 100755 index 0000000..c1dc50d --- /dev/null +++ b/libvcell/vcell_install/bionetgen/Perl2/Aux2/count_lines.pl @@ -0,0 +1,51 @@ +#!/usr/bin/perl + +$source=<<"EOF"; +BNGAgent.pm +BNGMessages.pm +BNGModel.pm +BNGOptions.pm +BNGUtils.pm +Compartment.pm +CompartmentList.pm +Component.pm +ComponentType.pm +Expression.pm +HNauty.pm +MacroBNGModel.pm +Map.pm +Molecule.pm +MoleculeType.pm +MoleculeTypesList.pm +Observable.pm +Param.pm +ParamList.pm +RateLaw.pm +Rxn.pm +RxnList.pm +RxnRule.pm +Species.pm +SpeciesGraph.pm +SpeciesList.pm +EOF + +# count lines of source code by the number of ;'s + +if (@ARGV){ + @files=@ARGV; +} else { + @files= split(' ',$source); +} +my $n_lines_tot=0; +for my $file (@files){ + my $n_lines=0; + open(IN,$file) || die "Couldn't open $file:$?\n"; + while(){ + if (/;\s*$/){ + ++$n_lines; + } + } + print "$file:$n_lines\n"; + $n_lines_tot+= $n_lines; +} +print "TOTAL:$n_lines_tot\n"; diff --git a/libvcell/vcell_install/bionetgen/Perl2/Aux2/countdown.pl b/libvcell/vcell_install/bionetgen/Perl2/Aux2/countdown.pl new file mode 100755 index 0000000..37e4485 --- /dev/null +++ b/libvcell/vcell_install/bionetgen/Perl2/Aux2/countdown.pl @@ -0,0 +1,6 @@ +#!/usr/bin/perl + +# doesn't work +for $i (10..1){ + print "$i\n"; +} diff --git a/libvcell/vcell_install/bionetgen/Perl2/Aux2/diff_cdat.pl b/libvcell/vcell_install/bionetgen/Perl2/Aux2/diff_cdat.pl new file mode 100755 index 0000000..d755933 --- /dev/null +++ b/libvcell/vcell_install/bionetgen/Perl2/Aux2/diff_cdat.pl @@ -0,0 +1,120 @@ +#!/usr/bin/perl + +# Program verify.pl compares two time course files. For the +# purpose of computing the norm error, the second file is the reference. +# +# Usage verify.pl datafile1 [datafile2] +# +# If no second filename is given, the script will automatically look in the +# database of results in the $BioNetGenRoot/VERIFY directory. +# +# Outputs: +# NORMERR: The computed norm error is printed +# Either SUCCESSFUL BUILD or PROBLEM WITH BUILD depending upon magnitude of +# norm error. The configuration variable $BUILD_ERR_THRESH can be set in +# bngrc or the local .bngrc file. +# +# Thanks to Robert Seletsky, the original author of this script, and Stan +# Steinberg, who suggested using the norm error +# err= |m2-m1|/|m2| +# = sqrt( sum_{ij}((m2_{ij} - m1_{ij})**2)/ sum_{ij}(m2_{ij})**2), +# where m1 and m2 are the arrays containing the time course data at i time +# points for j variables. + + +$BUILD_ERR_THRESH= 1e-7; +$COLUMN_OFFSET=0; + +# Read command line arguments +while ($ARGV[0] =~ /^-/){ + $_ = shift; + if (/^-offset$/){ + $COLUMN_OFFSET= shift; + } + else{ + exit_error("Unrecognized command line option $_"); + } +} + +if (($#ARGV!= 1)) { + die "Usage: $0 filename filename2\n"; +} +$rfilename = shift; +$rfilename2= shift; + +#print "Comparing $rfilename $rfilename2\n"; + +open (RFILE, $rfilename) or die "Can't open $rfilename: $!\n"; +$i=0; +@data=(); +@times=(); +while (){ + s/\#.*$//; # remove comments + next unless /\S+/; + ($time, @dat)= split(' '); + push @times, $time; + foreach $j (0..$#dat){ + $data[$i][$j]= $dat[$j]; + } + ++$i; +} +close(RFILE); + +open (RFILE, $rfilename2) or die "Can't open $rfilename2: $!\n"; +$i=0; +@data2=(); +@times2=(); +while (){ + s/\#.*$//; # remove comments + next unless /\S+/; + ($time, @dat)= split(' '); + push @times2, $time; + foreach $j (0..$#dat){ + $data2[$i][$j]= $dat[$j]; + } + ++$i; +} +close(RFILE); + +# Check that the time points in the two files are the same +if ($#times != $#times2){ + printf "Time points are incompatible\n"; + printf "%d time point(s)in $rfilename.\n", $#times+1; + printf "%d time point(s)in $rfilename2.\n", $#times2+1; + exit(1); +} +for $i (0..$#times){ + if ($times[$i]!= $times2[$i]){ + printf "Time points are incompatible\n"; + exit(1); + } +} + +# Compute normerr +$sresult= &normerr(\@data, \@data2); +print "$sresult\n"; +exit(0); + + +# Compute norm error between two data sets stored in two rectangular arrays m1 +# and m2 of the same dimension (not checked) +sub normerr { + my $m1= shift; + my $m2= shift; + + my $del2=0; + my $ref2=0; + + my $ilast= $#$m1; + my $jlast= $#{$$m1[0]}; + for my $i (0..$ilast){ + for my $j (0..$jlast){ + my $j2= $j+$COLUMN_OFFSET; +# print $$m2[$i][$j]," ", $$m1[$i][$j],"\n"; +# printf "$j $j2 %.2e %.2e\n", $$m1[$i][$j], $$m2[$i][$j2]; + $del2+= ($$m2[$i][$j2] - $$m1[$i][$j])**2; + $ref2+= ($$m2[$i][$j2])**2; + } + } + return (sqrt($del2/$ref2)); +} diff --git a/libvcell/vcell_install/bionetgen/Perl2/Aux2/express.pl b/libvcell/vcell_install/bionetgen/Perl2/Aux2/express.pl new file mode 100755 index 0000000..fa63542 --- /dev/null +++ b/libvcell/vcell_install/bionetgen/Perl2/Aux2/express.pl @@ -0,0 +1,164 @@ +#!/usr/bin/perl + +use Data::Dumper; + +$express= { + type=>'AND', +# type=>'OR', +# arg1=>{type=>'REF', arg1=>'a'}, + arg1=>{type=>'NOT', arg1=>{type=>'REF', arg1=>'a'}}, + arg2=>{type=>'REF', arg1=>'b'} + }; + +$list= ['a','b', 'ab','abc', 'ac', 'c','bc']; + +#print Dumper($express); +#print Dumper($list); + +# WARNING: NOT doesn't work properly unless it's surrounded by parenthesis + +#$string= "a AND (NOT c) AND b"; +#$string= "NOT (a AND b AND c)"; +#$string= "(a AND (NOT b)) OR (b AND (NOT a))"; +#$string= "(a OR b) AND (NOT (a AND b))"; +$string= "(a) AND (b)"; +$express= read_express(\$string); +print Dumper($express),"\n"; +print join(" ",@{eval_express($express, $list)}),"\n"; + +sub eval_express{ + my $express= shift; + my $list= shift; + + my $type= $express->{type}; + my $arg1= $express->{arg1}; + my $arg2= $express->{arg2}; + if ($type eq 'AND'){ + return(eval_express($arg2, eval_express($arg1,$list))); + } + elsif ($type eq 'OR'){ + my $list1= eval_express($arg1, $list); + my $list2= eval_express($arg2, $list); + return([@$list1,@$list2]); + } + elsif ($type eq 'XOR'){ + my $list1= eval_express($arg1, $list); + my $list2= eval_express($arg2, $list); + my %remove=(); + for my $item (@$list1){ + $remove{$item}=1; + } + my @lnew=(); + for my $item (@$list2){ + push @lnew, $item if (!($remove{$item})); + } + return([@lnew]); + } + elsif ($type eq 'NOT'){ + my $list1= eval_express($arg1, $list); + my %remove=(); + for my $item (@$list1){ + $remove{$item}=1; + } + my @lnew=(); + for my $item (@$list){ + push @lnew, $item if (!($remove{$item})); + } + return([@lnew]); + } + elsif ($type eq 'REF'){ + my @lnew= (); + for my $item (@$list){ + if ($item=~ /$arg1/){ + push @lnew, $item; + } + } + return([@lnew]); + } + else { + return(""); + } +} + +{ + my $open=0; + + sub read_express { + my $string= shift; + my $express=""; + my $expect_arg1=0; + my $expect_arg2=0; + while ($$string ne ""){ + my $nh={}; + $$string=~ s/^\s+//; + if ($$string=~ s/^\(// ){ + ++$open; + $nh= read_express($string); + } + elsif ($$string=~ s/^AND\s+//){ + $nh->{type}= 'AND'; + die "Null first operand for AND" unless ($express ne ""); + $nh->{arg1}= $express; + $express= $nh; + $expect_arg2=1; + next; + } + elsif ($$string=~ s/^OR\s+//){ + $nh->{type}= 'OR'; + die "Null first operand for OR" unless ($express ne ""); + $nh->{arg1}= $express; + $express= $nh; + $expect_arg2=1; + next; + } + elsif ($$string=~ s/^XOR\s+//){ + die "XOR not yet implemented"; + $nh->{type}= 'XOR'; + die "Null first operand for XOR" unless ($express ne ""); + $nh->{arg1}= $express; + $express= $nh; + $expect_arg2=1; + next; + } + elsif ($$string=~ s/^NOT\s+//){ + $nh->{type}= 'NOT'; + $express= $nh; + $expect_arg1=1; + next; + } + elsif ($$string=~ s/^([^\s\)]+)//){ + $nh->{type}='REF'; + $nh->{arg1}=$1; + } + elsif ($$string=~ s/^\)// ){ + --$open; + die "Unmatched end parenthesis" if ($open<0); + die "Empty parenthesis" if ($express eq ""); + return($express); + } + # print Dumper($nh),"\n"; + if ($express eq ""){ + $express= $nh; + } + elsif($expect_arg1){ + $express->{arg1}=$nh; + $expect_arg1=0; + } + elsif($expect_arg2){ + $express->{arg2}=$nh; + $expect_arg2=0; + } + else{ + die "Expression without operator"; + } + } + if ($expect_arg1){ + die "Missing unary operand"; + } + if ($expect_arg2){ + die "Missing binary operand"; + } + die "Missing end parenthesis" unless ($open==0); + return($express); + } +} diff --git a/libvcell/vcell_install/bionetgen/Perl2/Aux2/express_main.pl b/libvcell/vcell_install/bionetgen/Perl2/Aux2/express_main.pl new file mode 100755 index 0000000..8faa2c7 --- /dev/null +++ b/libvcell/vcell_install/bionetgen/Perl2/Aux2/express_main.pl @@ -0,0 +1,114 @@ +#!/usr/bin/perl + +use FindBin; +use lib $FindBin::Bin; +use Param; +use ParamList; +use Expression; + +$a1= Expression->new; +$a1->Type('NUM'); +$a1->Arglist([5]); + +$a2= Expression->new; +$a2->Type('NUM'); +$a2->Arglist([12]); + +#$a3= Expression->new; + +$expr= Expression->new; +$expr->Type('-'); +$expr->Arglist([($a1,$a2)]); + +printf "a1 evaluates to %s\n", $a1->evaluate(); +printf "a2 evaluates to %s\n", $a2->evaluate(); + +($val,$err) = $expr->evaluate(); +if ($err){ + die $err; +} +printf "expr evaluates to %s\n", $val; + +$string="45e-26"; +if (($number=getNumber(\$string)) ne ""){ + printf "Number is %g\n", $number; +} else { + printf "%s does not start with a valid number\n", $string; +} + +$plist= ParamList->new(); +$plist->set("a",5); +$plist->set("b",10); +$plist->set("c",-10); + +#$estring="1.01e-2*2-a/b+c^2"; +$estring="-a^2 + b"; +$estring_sav=$estring; +$expr= Expression->new(); +if ($err=$expr->readString(\$estring,$plist)){ + die $err; +} +printf "expr $estring_sav prints as %s\n", $expr->toString($plist); +($val,$err) = $expr->evaluate($plist); +if ($err){ + die $err; +} +printf "expr $estring_sav evaluates to %g\n", $val; + +printf "Before assignment, a=%d\n", $plist->evaluate("a"); +$estring="a=a+5"; +$err= ($expr=Expression->new())->readString(\$estring,$plist); +printf "After assignment, a=%d\n", $plist->evaluate("a"); + +$estring="x=(-a+5)/(c-10)"; +#$estring="x=5"; +$estring_sav=$estring; +$expr= Expression->new(); +if ($err=$expr->readString(\$estring,$plist)){ + die $err; +} +printf "expr $estring_sav prints as %s\n", $expr->toString($plist); +$val = $expr->evaluate($plist); +if ($expr->Err){ + die $expr->Err; +} +printf "expr $estring_sav evaluates to %g\n", $val; + +$estring="y=100^(d=1/2) g"; +$estring_sav=$estring; +$expr= Expression->new(); +if ($err=$expr->readString(\$estring,$plist,'\s')){ + die $err; +} +printf "expr $estring_sav prints as %s\n", $expr->toString($plist); +$val = $expr->evaluate($plist); +if ($expr->Err){ + die $expr->Err; +} +printf "expr $estring_sav evaluates to %g\n", $val; + +print $plist->writeBNGL(); +print $plist->toString(); + +#sub getNumber(){ +sub getNumber{ + my $string=shift; + my $number=""; + + # Decimal part + if ($$string=~ s/^([+-]?\d+[.]?\d*)//){ + $number=$1; + } + elsif ($$string=~ s/^([+-]?[.]\d+)//){ + $number=$1; + } else { + return(""); + } + + # Exponent part + if ($$string=~ s/^([DEFGdefg][+-]?\d+)//){ + $number.=$1; + } + return($number); +} + diff --git a/libvcell/vcell_install/bionetgen/Perl2/Aux2/group_size.pl b/libvcell/vcell_install/bionetgen/Perl2/Aux2/group_size.pl new file mode 100755 index 0000000..70a8c88 --- /dev/null +++ b/libvcell/vcell_install/bionetgen/Perl2/Aux2/group_size.pl @@ -0,0 +1,17 @@ +#!/usr/bin/perl +# Count number of species matching a group +my @gnames; +my %gsize; +while(<>){ + next unless (/^begin groups/); + while(<>){ + last if (/^end groups/); + (my $index, my $name, my $glist)= split(' '); + my @specs= split(',',$glist); + push @gnames, $name; + $gsize{$name}=scalar(@specs); + } +} +foreach $group (@gnames){ + printf "%s %d\n", $group, $gsize{$group}; +} diff --git a/libvcell/vcell_install/bionetgen/Perl2/Aux2/runBNG.pl b/libvcell/vcell_install/bionetgen/Perl2/Aux2/runBNG.pl new file mode 100755 index 0000000..bc984b7 --- /dev/null +++ b/libvcell/vcell_install/bionetgen/Perl2/Aux2/runBNG.pl @@ -0,0 +1,135 @@ +#!/usr/bin/perl +# $Id: runBNG.pl,v 1.2 2007/10/20 04:18:21 faeder Exp $ + +use FindBin; +use lib $FindBin::Bin; +use BNGModel; +use SpeciesList; +use BNGUtils; +use strict; + +# Set to nonzero value to equilibrate model prior to introduction of one +# or more species. This is required for the fceri model because there is a +# constitutive (present without ligand) interaction between Lyn and FceRI. +my $t_equil=1000; +my $max_equil=100; +my @spec_equil=("Lig(l,l)"); + +# End point of production simulation and time point at which outputs will +# be reported. +my $t_end=600; +my $n_steps=1; +# Names of observables reported at integration end point +my @output_vars=("RecSykPS"); + +# Force regeneration of network prior to simulation +my $force_netgen=0; + +#------ END OF USER DEFINED PARAMETERS ------- + +my $model= BNGModel->new(); +my %params=(); +while ($ARGV[0] =~ /^-/){ + $_ = shift; + if (/^-g$/){ + $force_netgen=1; + } + else{ + exit_error("Unrecognized command line option $_"); + } +} + +# Get prefix and determine whether network has been generated +my $prefix= shift(@ARGV); + +# Dup original STDOUT +open my $oldout, ">&STDOUT" or die "Can't dup STDOUT: $!"; + +# Redirect STDOUT to logfile +open(STDOUT,">${prefix}_runBNG.log"); + +# turn off output buffering on STDOUT +(select(*STDOUT), $|=1)[0]; + +printf "BioNetGen version %s\n", BNGversion(); + +if (!$force_netgen && -r "$prefix.net"){ + # Read previously generate net file + my $file= "$prefix.net"; + $params{file}=$file; + if (my $err=$model->readFile(\%params)){exit_error($err);} +} elsif (-r "$prefix.bngl") { + # Read BNGL file and generate network + my $file= "$prefix.bngl"; + $params{file}=$file; + if (my $err=$model->readFile(\%params)){exit_error($err);} + if (my $err=$model->generate_network({overwrite=>1})){exit_error($err);} +} else { + exit_error("No BNGL or NET file could be found with prefix $prefix."); +} + +# Hash indices of observables +my %obs_ind=(); +my $oind=0; +for my $obs (@{$model->Observables}){ + $obs_ind{$obs->Name}= $oind++; +} + +# Set parameters to value of arguments +my $iparam=0; +for my $pvalue (@ARGV){ + if (my $err=$model->ParamList->setIndex($iparam,$pvalue)){exit_error($err);} + ++$iparam; +} + +# Perform equilibration +if ($t_equil>0){ + # Set equilibration variables to zero + my %val_equil=(); + my $oldval; + for my $spec (@spec_equil){ + # determine whether variable is species or concentration + (my $err, my $oldval)= $model->setConcentration($spec,0); + $err && exit_error($err); + $val_equil{$spec}= $oldval; + } + my $suff="runBNG_equil"; + if (my $err=$model->simulate_ode({suffix=>$suff,t_end=>$t_equil,n_steps=>$max_equil,steady_state=>1,sparse=>1})){exit_error($err);} + # Reset equilibration variables + for my $spec (@spec_equil){ + (my $err, my $oldval)= $model->setConcentration($spec,$val_equil{$spec}); + $err && exit_error($err); + } +} + +# Run simulation +my $suff="runBNG_run"; +if (my $err=$model->simulate_ode({suffix=>$suff,t_end=>$t_end,n_steps=>$n_steps})){exit_error($err);} + +# Report results +my $gdatfile= $prefix."_".$suff.".gdat"; +my @output=(); +if (-r "$gdatfile"){ + print "Updating observable concentrations from $gdatfile\n"; + open(GDAT, "$gdatfile"); + my $last=""; + while(){ + $last=$_; + } + close(GDAT); + (my $time, my @gconc)= split(' ', $last); + for my $oname (@output_vars){ +# push @output, "$oname:".$gconc[$obs_ind{$oname}]; + push @output, $gconc[$obs_ind{$oname}]; + } +}else { + exit_error("Could not find $gdatfile"); +} + +printf "CPU TIME: total %.1f s.\n", cpu_time(0); + +open STDOUT, ">&", $oldout or die "Can't dup \$oldout: $!"; +# Print results to real STDOUT (to be read by Matlab) +print join(" ",@output),"\n"; + + diff --git a/libvcell/vcell_install/bionetgen/Perl2/Aux2/test.pl b/libvcell/vcell_install/bionetgen/Perl2/Aux2/test.pl new file mode 100755 index 0000000..0dccc73 --- /dev/null +++ b/libvcell/vcell_install/bionetgen/Perl2/Aux2/test.pl @@ -0,0 +1,21 @@ +#!/usr/bin/perl +# $Id: BNG2.pl,v 1.5 2005/11/08 16:41:35 faeder Exp $ + +use FindBin; +use lib $FindBin::Bin; +use BNGModel; +use SpeciesList; +use BNGUtils; +use strict; + +# turn off output buffering on STDOUT +#(select(*STDOUT), $|=1)[0]; + +#printf "BioNetGen version %s\n", BNGversion(); + +#$model= BNGModel->new(); +my ($a, $b, $c); + +my $s= \"111"; + +print $$s,"\n"; diff --git a/libvcell/vcell_install/bionetgen/Perl2/Aux2/test_compartment.pl b/libvcell/vcell_install/bionetgen/Perl2/Aux2/test_compartment.pl new file mode 100755 index 0000000..a5e4c99 --- /dev/null +++ b/libvcell/vcell_install/bionetgen/Perl2/Aux2/test_compartment.pl @@ -0,0 +1,56 @@ +#!/usr/bin/perl + +use FindBin; +use lib $FindBin::Bin; +use Compartment; +use CompartmentList; + +my $clist= CompartmentList->new; +my $plist= ParamList->new; +$clist->setDefault(); +# Check valid compartment setup/listing +print $clist->toString(); + +# Test adjacency function +for my $comp1 (@{$clist->Array}){ + for my $comp2 (@{$clist->Array}){ + if ($comp1->adjacent($comp2)){ + printf "%s adjacent to %s\n", $comp1->Name, $comp2->Name; + } + } +} + + +# Check setting of compartment volume +my $x="100"; +if ($err=$clist->lookup("PM")->setVolume($x,$plist)){ + die $err; +} +print "After setting PM volume to $x\n"; +print $clist->setVolumeStrings(); + +# Test connected function + +if (!($clist->lookup("EC")->connected($clist->lookup("NM"), $clist->lookup("NU")))){ + print "Connected PASSED test 1\n"; +} else { + print "Connected FAILED test 1\n"; +} + +if (($clist->lookup("EC")->connected($clist->lookup("CP"), $clist->lookup("PM")))){ + print "Connected PASSED test 2\n"; +} else { + print "Connected FAILED test 2\n"; +} + +if (($clist->lookup("EC")->connected($clist->lookup("CP")))){ + print "Connected FAILED test 3\n"; +} else { + print "Connected PASSED test 3\n"; +} + +if (($clist->lookup("EC")->connected($clist->lookup("CP"), $clist->lookup("PM"), $clist->lookup("NM")))){ + print "Connected PASSED test 4\n"; +} else { + print "Connected FAILED test 4\n"; +} diff --git a/libvcell/vcell_install/bionetgen/Perl2/Aux2/test_molorder.pl b/libvcell/vcell_install/bionetgen/Perl2/Aux2/test_molorder.pl new file mode 100755 index 0000000..d5d0121 --- /dev/null +++ b/libvcell/vcell_install/bionetgen/Perl2/Aux2/test_molorder.pl @@ -0,0 +1,20 @@ +#!/usr/bin/perl + + +$perm= [3,1,2]; +@molecules=("a","b","c"); +print "before sort: ",join(" ",@molecules),"\n"; + +# Reorder Molecules according to canonical order +my @mol_perm=(); + +#$imol=0; +#for $mol (@molecules){ +# push @mol_perm, [$$perm[$imol],$mol]; +# ++$imol; +#} +@mol_perm= map {[$perm->[$_],$molecules[$_]]} (0..$#molecules); +@mol_perm= sort {$a->[0]<=>$b->[0]} @mol_perm; +@molecules= map {$_->[1]} @mol_perm; +print " after sort: ",join(" ",@molecules),"\n"; + diff --git a/libvcell/vcell_install/bionetgen/Perl2/Aux2/test_redirect.pl b/libvcell/vcell_install/bionetgen/Perl2/Aux2/test_redirect.pl new file mode 100755 index 0000000..a8dfe19 --- /dev/null +++ b/libvcell/vcell_install/bionetgen/Perl2/Aux2/test_redirect.pl @@ -0,0 +1,19 @@ +#!/usr/bin/perl + +open my $oldout, ">&STDOUT" or die "Can't dup STDOUT: $!"; +open OLDERR, ">&", \*STDERR or die "Can't dup STDERR: $!"; + +open STDOUT, '>', "$0.out" or die "Can't redirect STDOUT: $!"; +open STDERR, ">&STDOUT" or die "Can't dup STDOUT: $!"; + +select STDERR; $| = 1; # make unbuffered +select STDOUT; $| = 1; # make unbuffered + +print STDOUT "stdout 1\n"; # this works for +print STDERR "stderr 1\n"; # subprocesses too + +open STDOUT, ">&", $oldout or die "Can't dup \$oldout: $!"; +open STDERR, ">&OLDERR" or die "Can't dup OLDERR: $!"; + +print STDOUT "stdout 2\n"; +print STDERR "stderr 2\n"; diff --git a/libvcell/vcell_install/bionetgen/Perl2/Aux2/test_sub.pl b/libvcell/vcell_install/bionetgen/Perl2/Aux2/test_sub.pl new file mode 100755 index 0000000..0a8388a --- /dev/null +++ b/libvcell/vcell_install/bionetgen/Perl2/Aux2/test_sub.pl @@ -0,0 +1,13 @@ +#!/usr/bin/perl + +use FindBin; +use lib $FindBin::Bin; +use SpeciesGraph; + +while(<>){ + next unless /S+/; + my $sg= SpeciesGraph->new; + chomp; + $err=$sg->readString(\$_); + if ($err){die($err);} +} diff --git a/libvcell/vcell_install/bionetgen/Perl2/BNGAction.pm b/libvcell/vcell_install/bionetgen/Perl2/BNGAction.pm new file mode 100644 index 0000000..67f126c --- /dev/null +++ b/libvcell/vcell_install/bionetgen/Perl2/BNGAction.pm @@ -0,0 +1,2110 @@ +package BNGModel; +# BNGAction is part of the BNGModel package. This file contains Action commands +# including: simulate, simulate_nf, simulate_pla, generate_hybrid_model, ... + +# +# pragmas +use strict; +use warnings; + +### +### +### + +# Process a value that is either a number or an expression defined in terms of parameters +# in the plist. Used to allow argument strings to be either numbers or expressions. +sub process_val_express{ + my $val_string= shift; + my $plist = shift; + + # Read expression + my $expr = Expression->new(); + my $estring = $val_string; + if ( my $err = $expr->readString( \$estring, $plist ) ) + { + return ( '', $err ); + } + return($expr->evaluate($plist)); +} + +sub simulate_protocol +{ + my $model = shift @_; + my $params = (@_) ? shift @_ : {}; + + my $simulation_protocol_ref = $model->{simulation_protocol}; + my @simulation_protocol = @{$simulation_protocol_ref}; + my $num_commands = scalar(@simulation_protocol); + + print "\n\nexecuting $num_commands commands in protocol\n\n"; + + my $err; + + for(my $k=0;$k<$num_commands;$k++) + { + my $action = $model->{simulation_protocol}[$k]->{action}; + my $options = $model->{simulation_protocol}[$k]->{options}; + my $modified_options; + + if(index($action,"simulate") != -1) + { + my $hash_opts_ref = eval($options); + #modifying hash with local prefix + $hash_opts_ref->{prefix} = $params->{prefix}; + #deleting suffix + delete $hash_opts_ref->{suffix}; + $err = $model->simulate($hash_opts_ref); + + } + else + { + $modified_options = $options; + my $command = sprintf "\$model->%s(%s);", $action, $modified_options; + my $t_start = cpu_time(0); + $err = eval $command; + #if ($@) { $err = errgen($@); goto EXIT; } + #if ($err) { $err = errgen($err); goto EXIT; } + my $t_elapsed = cpu_time($t_start); + printf "CPU TIME: %s %.2f s.\n", $action, $t_elapsed; + } + + } + return $err; +} + + + +sub simulate_ode +{ + my $model = shift @_; + my $params = (@_) ? shift @_ : {}; + + $params->{method} = 'cvode'; + my $err = $model->simulate( $params ); + return $err; +} + + +sub simulate_ssa +{ + my $model = shift @_; + my $params = (@_) ? shift @_ : {}; + + $params->{method} = 'ssa'; + my $err = $model->simulate( $params ); + return $err; +} + + +sub simulate_pla +{ + my $model = shift @_; + my $params = (@_) ? shift @_ : {}; + + $params->{method} = 'pla'; + my $err = $model->simulate( $params ); + return $err; +} + + +sub simulate_psa +{ + my $model = shift @_; + my $params = (@_) ? shift @_ : {}; + + $params->{method} = 'psa'; + my $err = $model->simulate( $params ); + return $err; +} + + + +### +### +### + + +# all purpose simulation method (supports 'NFsim by calling 'simulate_nf' if method = "nf") +sub simulate +{ + use IPC::Open3; + use IO::Select; + + my $model = shift @_; + my $params = (@_) ? shift @_ : {}; + my $err; + + + my $METHODS = + { + cvode => { binary=>'run_network', type=>'Network', input=>'net', + options=>{ atol=>1, rtol=>1, sparse=>1, steady_state=>1 } }, + ssa => { binary=>'run_network', type=>'Network', input=>'net', + options=>{ seed=>1 } }, + pla => { binary=>'run_network', type=>'Network', input=>'net', + options=>{ seed=>1 } }, + psa => { binary=>'run_network', type=>'Network', input=>'net', + options=>{ seed=>1} }, + nf => { binary=>'NFsim', type=>'NetworkFree', input=>'xml', + options=>{ seed=>1 } } + }; + + return '' if $BNGModel::NO_EXEC; + + # Read simulation arguments from file + my @sample_times; + my $argfile = defined $params->{argfile} ? $params->{argfile} : undef; + if ($argfile) + { + print "Reading simulation arguments from $argfile.\n"; + open(ARGS, "<", $argfile) or return "Could not open argfile '$argfile'."; + my $lineCounter = 0; + while (my $line = ) + { + ++$lineCounter; + # trim comments + $line =~ s/#.*$//; + # skip empty lines + next unless ( $line =~ /\S/ ); + # split tokens + my @args = split " ", $line; + + unless (@args == 2) + { return "Could not process line $lineCounter in $argfile: wrong number of arguments."; } + + print "Processing argument: "; + # Check if Arg is already defined in action call + if ( !(defined $params->{$args[0]}) ) + { + if ( $args[0] ne 'sample_times' ){ + $params->{$args[0]} = $args[1]; + printf "$args[0] => %s\n", (looks_like_number($args[1]) ? $args[1] : "'$args[1]'"); + } + else + { # Special handling for sample_times array + print "$args[0] => $args[1]\n"; + # evaluate sample_times string to get array ref (hopefully) + my $sample_times = eval $args[1]; + if ($@) + { return "Problem parsing 'sample_times': Sample times must be comma-separated (no spaces) ints or floats " + . "(exponential format ok) enclosed in square brackets, e.g., [5e-1,1,5.0,1E1]."; + } + @sample_times = @$sample_times; + foreach my $sample (@sample_times) + { # check that sample time is a number + unless ( looks_like_number($sample) ) + { return "Problem parsing 'sample_times': Sample times must be comma-separated (no spaces) ints or floats " + . "(exponential format ok) enclosed in square brackets, e.g., [5e-1,1,5.0,1E1]."; + } + } + } + } + else + { # Args in the action call take precedence + if ( $args[0] ne 'sample_times' ) + { printf "'$args[0]' already defined with value %s, moving on...\n", + (looks_like_number($params->{$args[0]}) ? "$params->{$args[0]}" : "'$params->{$args[0]}'"); + } + else + { printf "'$args[0]' already defined in action call, moving on...\n"; } + } + } + close ARGS; + printf "Finished.\n"; + } + + # general options + my $method = defined $params->{method} ? $params->{method} : undef; + my $verbose = defined $params->{verbose} ? $params->{verbose} : 0; + my $prefix = defined $params->{prefix} ? $model->getOutputPrefix( $params->{prefix} ) : $model->getOutputPrefix(); + my $suffix = defined $params->{suffix} ? $params->{suffix} : undef; + my $netfile = defined $params->{netfile} ? $params->{netfile} : undef; + my $print_end = defined $params->{print_end} ? $params->{print_end} : 0; + my $print_net = defined $params->{print_net} ? $params->{print_net} : 0; + my $save_progress = defined $params->{save_progress} ? $params->{save_progress} : 0; # Same as 'print_net' + my $continue = defined $params->{'continue'} ? $params->{'continue'} : 0; + my $print_active = defined $params->{print_n_species_active} ? $params->{print_n_species_active} : 0; + my $print_cdat = defined $params->{print_CDAT} ? $params->{print_CDAT} : 1; # Default is to print .cdat + my $print_fdat = defined $params->{print_functions} ? $params->{print_functions} : 0; # Default is to NOT print .fdat + my $stop_if = defined $params->{stop_if} ? $params->{stop_if} : undef; # stop condition + my $print_on_stop = defined $params->{print_on_stop} ? $params->{print_on_stop} : undef; # print at point that stop condition is met + my $max_sim_steps = defined $params->{max_sim_steps} ? $params->{max_sim_steps} : undef; + my $output_step_interval = defined $params->{output_step_interval} ? $params->{output_step_interval} : undef; + + # continuous options + my $atol = defined $params->{atol} ? $params->{atol} : 1e-8; + my $rtol = defined $params->{rtol} ? $params->{rtol} : 1e-8; + my $sparse = defined $params->{sparse} ? $params->{sparse} : 0; + my $steady_state = defined $params->{steady_state} ? $params->{steady_state} : 0; + + # stochastic options +# my $seed = defined $params->{seed} ? $params->{seed} : floor(rand 2**31); + if ( not defined $params->{seed} ){ + # do this so that NFsim gets the seed generated by BNG --LAH + $params->{seed} = floor(rand 2**31); + } + my $seed = $params->{seed}; + + # Default to HAS method if scalelevel is defined + # note, this needs to be changed once the name changes + # to PLA/poplevel/popscale occur + if(defined $params->{poplevel}){ + $method="psa" + } + + # check method + unless ( $method ) + { return "simulate() requires 'method' parameter (ode, ssa, pla, psa, nf)."; } + if ($method =~ /^ode$/){ $method = 'cvode'; } # Support 'ode' as a valid method + unless ( exists $METHODS->{$method} ) + { return "Simulation method '$method' is not a valid option."; } + + printf "ACTION: simulate( method=>\"%s\" )\n", $method; + + #if the method is ode or ssa or pla, check if the reaction network has been generated, and if not, generate it. + if ($method =~ /^(cvode|ssa|pla|psa)$/) + { + if($model->RxnList->size()==0) + { + if ($err = $model->generate_network()){return $err;}; + } + } + + # add optional suffix to output prefix + if ( defined $suffix ) + { $prefix .= "_" . $suffix; } + + # If stop condition is defined add it to the list of functions + if ($stop_if){ + (my $ref, $err) = $model->ParamList->lookup("_stop_if"); + if (!$ref){ + my $fun = Function->new(); + if ( $err = $fun->readString( "_stop_if() " . $stop_if, $model ) ){ return $err; } + # check paramlist for unresolved dependency, etc + if ( $err = $model->ParamList->check() ){ return $err; } + # update netfile since new function was added + $model->UpdateNet(1) + } + } + + # Process shared parameters t_start and t_end in case they are input as expressions + if (defined $params->{t_start}){ + $params->{t_start}= process_val_express($params->{t_start}, $model->ParamList ); + print("TSTART:", $params->{t_start},"\n"); + } + if (defined $params->{t_end}){ + $params->{t_end}= process_val_express($params->{t_end}, $model->ParamList ); + print("TEND:", $params->{t_end},"\n"); + } + + # Find binary + my $binary = $METHODS->{$method}->{binary}; + printf "%s simulation using %s\n", $METHODS->{$method}->{type}, $method; + my $program; + unless ( $program = findExec($binary) ) + { return "Could not find executable $binary"; } + + # If method = "nf", call simulate_nf() and return + if ( $method eq 'nf' ){ + return $model->simulate_nf( $params ); + } + + # Network simulation + # Find or Create netfile + my $netpre; + if ($netfile) + { + # user defined netfile + # Make sure NET file has proper suffix + ($netpre = $netfile) =~ s/[.]([^.]+)$//; + unless ( $1 =~ /net/i ) + { return "File $netfile does not have .net suffix"; } + } + else + { + # default to [prefix].net + $netfile = "${prefix}.net"; + $netpre = $prefix; + + # Generate NET file if not already created or if updateNet flag is set + if ( !(-e $netfile) or $model->UpdateNet or defined $params->{prefix} or defined $suffix ) + { + $err = $model->writeNetwork({include_model=>0, overwrite=>1, prefix=>"$netpre"}); + if ($err) { return $err; } + } + } + + # Begin writing command: start with program + my @command = ($program); + + # add output prefix + push @command, "-o", "$prefix"; + + # add method to command + push @command, "-p", "$method"; + + # pla-specific arguments + if ($method eq 'pla') + { + if (!exists $params->{pla_config}){ + $params->{pla_config} = "fEuler|pre-neg:sb|eps=0.03"; + send_warning("'pla_config' not defined, using default: $params->{pla_config}"); + } + push @command, $params->{pla_config}; + if (defined $params->{pla_output}){ + push @command, "--pla_output", $params->{pla_output}; + } + } + + # heterogeneous adaptive scaling method - specific arguments + if ($method eq 'psa') + { + if (!exists $params->{poplevel}) { + $params->{poplevel} = "100"; + send_warning("'poplevel' not defined, using default scaling targert: $params->{poplevel}"); + } + push @command, "--poplevel", $params->{poplevel}; + if (exists $params->{check_product_scale}) { + push @command, "--check_product_scale", $params->{check_product_scale}; + } + } + if ($method eq 'ssa') + { + if ( exists $params->{poplevel} ) { + push @command, "--poplevel", $params->{poplevel}; + if (exists $params->{check_product_scale}) { + push @command, "--check_product_scale", $params->{check_product_scale}; + } + } + } + + # add method options + { + my $opts = $METHODS->{$method}->{options}; + if ( exists $opts->{seed} ) + { # random seed + push @command, "-h", $seed; + } + if ( exists $opts->{atol} ) + { # absolute tolerance + push @command, "-a", $atol; + } + if ( exists $opts->{rtol} ) + { # absolute tolerance + push @command, "-r", $rtol; + } + if ( exists $opts->{sparse} ) + { # sparse methods + if ($sparse) { push @command, "-b"; } + } + if ( exists $opts->{steady_state} ) + { # check for steady state + if ($steady_state) { push @command, "-c"; } + } + } + + # define update_interval + my $update_interval = defined $params->{update_interval} ? $params->{update_interval} : 1.0; + + # define expand + my $expand = defined $params->{expand} ? $params->{expand} : 'lazy'; + if ( $expand eq 'lazy' ) { } + elsif ( $expand eq 'layered' ) { } + else { return "Unrecognized expand method $expand"; } + + # define maximum # of sim steps + if (defined $max_sim_steps) + { push @command, "-M", $max_sim_steps; } + + # define output step interval + if (defined $output_step_interval) + { push @command, "-I", $output_step_interval; } + + # stop condition + if ($stop_if){ + push @command, "--stop_cond", $stop_if; + if ($print_on_stop){ + push @command, $print_on_stop; + } + else{ + push @command, "1"; # Default is to print on stop + } + } + + # output concentrations data + push @command, "--cdat", $print_cdat; + # output function values + push @command, "--fdat", $print_fdat; + + # define print_net (save_progress) + if (defined $params->{print_net} && defined $params->{save_progress}){ # Don't let them both be defined + return "'print_net' and 'save_progress' are the same thing, cannot define both. " + . "Please only define one ('save_progress' is preferred)."; + } + if ($print_net || $save_progress) { push @command, "-n"; } + # define print_end + if ($print_end) { push @command, "-e"; } + # More detailed output + if ($verbose) { push @command, "-v"; } + # Continuation + if ($continue) { push @command, "-x"; } + # Print number of active species + if ($print_active) { push @command, "-j"; } + + + # Set start time for trajectory + my $t_start; + my $tol=1e-15; + if ( defined $params->{t_start} ) + { + $t_start= $params->{t_start}; + # if this is a continuation, check that model time equals t_start + if ($continue) + { + unless ( defined($model->Time) and (abs($model->Time - $t_start) < $tol) ) + { return "t_start must equal current model time for continuation."; } + } + } + else + { # t_start defaults to 0 + if ( $continue and defined($model->Time) ) + { $t_start = $model->Time; } + else + { $t_start = 0.0; } + } + + # Set the model time to t_start + $model->Time($t_start); + + # To preserve backward compatibility: only output start time if != 0 + unless ( $t_start == 0.0 ) + { push @command, "-i", "$t_start"; } + + # Use program to compute observables + push @command, "-g", $netfile; + + # Read network from $netfile + push @command, $netfile; + + # define t_end and n_steps + my ($n_steps, $t_end); + if ( (defined $params->{n_steps} || defined $params->{n_output_steps}) && + (defined $params->{sample_times} || @sample_times) ){ + # Throw warning if both n_steps and sample_times are defined + my $x = ( defined $params->{n_steps} ) ? "n_steps" : "n_output_steps"; + send_warning("$x and sample_times both defined. $x takes precedence."); + } + if ( defined $params->{n_steps} || defined $params->{n_output_steps} || + ( !defined $params->{sample_times} && !@sample_times) ) + { + if ( defined $params->{n_steps} && defined $params->{n_output_steps} ){ # Don't let them both be defined + return "'n_steps' and 'n_output_steps' are the same thing, cannot define both. " + . "Please only define one ('n_output_steps' is preferred)."; + } + + if ( defined $params->{t_end} ){ + $t_end= $params->{t_end}; + } + else{ + return "Parameter t_end must be defined."; + } + + if ( ($t_end - $t_start) <= 0.0 ) + { + send_warning("t_end (" . $t_end . ") is not greater than t_start (" . $t_start . "). " . + "Simulation won't run." . + "\nPlease check the BNGL file to make sure you didn't use a parameter as an argument value in the simulate action."); + } + + if (defined $params->{n_steps}){ + $n_steps = $params->{n_steps}; + } + elsif (defined $params->{n_output_steps}){ + $n_steps = $params->{n_output_steps}; + } + else{ + $n_steps = 1; + } + + my $step_size = ($t_end - $t_start) / $n_steps; + push @command, $step_size, $n_steps; + } + else + { + if (defined $params->{sample_times}) + { @sample_times = @{$params->{sample_times}}; } + @sample_times = sort {$a <=> $b} @sample_times; # numeric sort + if ( @sample_times > 2 ){ + if ( defined $params->{t_end} ){ + $t_end = $params->{t_end}; + push @sample_times, $t_end; + } + else{ + $t_end = $sample_times[ $#sample_times ]; + } + push @command, @sample_times; # add sample times to argument list + } + else{ + return "'sample_times' array must contain 3 or more points."; + } + } + + # Determine index of last rule iteration + my $n_iter = 0; + if ( $model->SpeciesList ) + { + foreach my $spec ( @{$model->SpeciesList->Array} ) + { + my $iter = $spec->RulesApplied; + $n_iter = ( $iter > $n_iter ) ? $iter : $n_iter; + } + } + + + ### RUN SIMULATION ### + print "Running run_network on ", `hostname`; + printf "full command: %s\n", join(" ", @command); + + # disable dospath warnings for Windows OS. + use Config; + if ( $Config{'osname'} eq 'MSWin32' ) + { $ENV{'CYGWIN'}='nodosfilewarning'; } + + # start simulator as child process with communication pipes + local ( *Reader, *Writer, *Err ); + my $pid = eval{ open3( \*Writer, \*Reader, \*Err, @command ) }; + if ($@) { return sprintf("%s failed: $@", join(" ", @command)); } + + # remember child PID + $::CHILD_PID = $pid; + print "[simulation PID is: $pid]\n"; + + # Wait for messages from the Simulator + my $last_msg = ''; + my $steady_state_reached = 0; + my $edge_warning = 0; + my $otf = 0; + + while ( my $message = ) + { + # If network generation is on-the-fly, look for signal that + # species at the edge of the network is newly populated + if ( $message =~ /Steady state reached/ ) + { # steady state message + $steady_state_reached = 1; + } + elsif ( $message =~ s/^edgepop:\s*// ) + { + # remember that we've attempted On-the-fly! + $otf = 1; + + unless ( $model->SpeciesList ) + { # Can't generate new species if running from netfile + # TODO: I don't think it's sufficient to check if SpeciesList is defined. + # It's possible that it exists but the Network generation infrastructure is missing --Justin + ++$edge_warning; + print Writer "continue\n"; + next; + } + + # parse edgepop message + my (@newspec) = split /\s+/, $message; + + my $species; + ++$n_iter; + if ( $expand eq 'lazy' ) + { + my (@sarray, $spec); + foreach my $sname (@newspec) + { + unless ( $spec = $model->SpeciesList->lookup_bystring($sname) ) + { return "Couldn't find species $sname."; } + push @sarray, $spec; + } + if ($verbose) + { printf "Applying rules to %d species\n", scalar @sarray; } + $species = \@sarray; + } + else + { # Do full next iteration of rule application + $species = $model->SpeciesList->Array; + } + + # Apply reaction rules + my $nspec = $model->SpeciesList->size(); + my $nrxn = $model->RxnList->size(); + my $irule = 1; + my ($n_new, $t_off); + foreach my $rset ( @{$model->RxnRules} ) + { + if ($verbose) { $t_off = cpu_time(0); } + $n_new = 0; + foreach my $rr (@$rset) + { + # expand rule + my ($err, $nr) = $rr->expand_rule( $species, $model, $params ); + if (defined $err) + { return "Some problem expanding rule (OTF): $err"; } + $n_new += $nr; + + } + if ($verbose) + { + printf "Rule %3d: %3d new reactions %.2e s CPU time\n", + $irule, $n_new, cpu_time(0) - $t_off; + } + ++$irule; + } + + # Set RulesApplied attribute to everything in @$species + foreach my $spec (@$species) + { + $spec->RulesApplied($n_iter) unless ($spec->RulesApplied); + } + + # Set RulesApplied attribute to everything in SpeciesList + my $new_species = []; + foreach my $spec ( @{$model->SpeciesList->Array} ) + { + push @$new_species, $spec unless ($spec->RulesApplied); + } + + # Print new species, reactions, and observable entries + if ( $model->RxnList->size() > $nrxn ) + { + print Writer "read\n"; + $model->SpeciesList->print( *Writer, $nspec ); + $model->RxnList->print( *Writer, $nrxn ); + print Writer "begin groups\n"; + my $i = 1; + foreach my $obs ( @{$model->Observables} ) + { + print Writer "$i "; + $obs->printGroup( *Writer, $model->SpeciesList->Array, $nspec ); + ++$i; + } + print Writer "end groups\n"; + } + else + { + print Writer "continue\n"; + } + } + else + { + print $message; + $last_msg = $message; + } + } + + # Simulator is finished + my @err = ; + close Writer; + close Reader; + close Err; + waitpid( $pid, 0 ); + + # clear child pid + $::CHILD_PID = undef; + + # Report number of times edge species became populated without network expansion + if ($edge_warning) + { send_warning("Edge species of truncated network became populated $edge_warning times."); } + + if (@err) + { # print any errors received from + print @err; + return sprintf("%s\n did not run successfully.", join(" ", @command)); + } + + unless ( $last_msg =~ /^Program times:/ ) + { return sprintf("%s\n did not run successfully.", join(" ", @command)); } + + + + + # At this point, the simulation seems to be ok. + # Go ahead and print out final netfile (if there are new reactions or species) + if ( $otf and $model->SpeciesList ) + { # TODO: I don't think it's sufficient to check if SpeciesList is defined. + # It's possible that it exists but the Network generation infrastructure is missing --Justin + $err = $model->writeNetwork({include_model=>0, overwrite=>1, prefix=>"$netpre"}); + if ($err) { return $err; } + } + + + # Report steady state + if ($steady_state) + { + if ($steady_state_reached) + { # let user know simulation reached steady state + print "Simulation reached steady state by t_end=${t_end}\n"; + } + else + { # warn user about failure to acheive steady state + send_warning("Steady_state status = $steady_state_reached."); + return "Simulation did not reach steady state by t_end=${t_end}"; + } + } + + # If there are no errors or flags so far, let's load output concentrations + if ( !($model->RxnList) ) + { # TODO: what does this accomplish? --Justin + send_warning("Not updating species concentrations because no model has been read."); + } + elsif ( -e "$prefix.cdat" ) + { + print "Updating species concentrations from $prefix.cdat\n"; + open CDAT, '<', "$prefix.cdat" ; + my $last_line = ''; + while (my $line = ) { $last_line = $line; } + close CDAT; + + # Update Concentrations with concentrations from last line of CDAT file + my $conc; + ($t_end, @$conc) = split ' ', $last_line; + my $species = $model->SpeciesList->Array; + unless ( $#$conc == $#$species ) + { + $err = sprintf "Number of species in model (%d) and CDAT file (%d) differ", scalar @$species, scalar @$conc; + return $err; + } + $model->Concentrations( $conc ); + $model->UpdateNet(1); + } + else + { return "CDAT file is missing"; } + + # Set model time to t_end + $model->Time($t_end); + + # all finished! + return ''; +} + + + +### +### +### + + + +sub simulate_nf +{ + use IPC::Open3; + + my $model = shift @_; + my $params = shift @_; + my $err; + + printf "ACTION: simulate_nf( )\n"; + + # get simulation output prefix + my $prefix = defined $params->{prefix} ? $model->getOutputPrefix( $params->{prefix} ) : $model->getOutputPrefix(); + my $suffix = defined $params->{suffix} ? $params->{suffix} : ""; + + unless ($suffix eq "") + { $prefix .= "_${suffix}"; } + + # TODO: detect unrecognized parameters + + # map BNG options to NFsim flags + my %nfparams = + ( # option name type defaults simulator flags (one or more) + binary_output => { type => 'switch', default_arg => 0, flags => ["-b"] }, + complex => { type => 'switch', default_arg => 1, flags => ["-cb"] }, + equil => { type => 'param', default_arg => undef, flags => ["-eq"] }, + get_final_state => { type => 'switch', default_arg => 1, flags => ["-ss","${prefix}.species"] }, + gml => { type => 'param', default_arg => undef, flags => ["-gml"] }, + nocslf => { type => 'switch', default_arg => 0, flags => ["-nocslf"] }, + notf => { type => 'switch', default_arg => 0, flags => ["-notf"] }, + print_functions => { type => 'switch', default_arg => 0, flags => ["-ogf"] }, + seed => { type => 'param', default_arg => undef, flags => ["-seed"] }, + utl => { type => 'param', default_arg => undef, flags => ["-utl"] }, + verbose => { type => 'switch', default_arg => 0, flags => ["-v"] } + ); + + # get nfsim arguments + my @args = (); + while ( my ($arg,$arg_hash) = each %nfparams ) + { + if ($arg_hash->{type} eq "switch") + { + if (defined $params->{$arg}) + { # user switch + if ($params->{$arg}) + { push @args, @{$arg_hash->{flags}}; } + } + elsif (defined $arg_hash->{default_arg}) + { # default switch + $params->{$arg} = $arg_hash->{default_arg}; + if ($arg_hash->{default_arg}) + { push @args, @{$arg_hash->{flags}}; } + + } + } + elsif ($arg_hash->{type} eq "param") + { + if (defined $params->{$arg}) + { # user parameter + push @args, @{$arg_hash->{flags}}, $params->{$arg}; + } + elsif (defined $arg_hash->{default_arg}) + { # user parameter + push @args, @{$arg_hash->{flags}}, $arg_hash->{default_arg}; + $params->{$arg} = $arg_hash->{default_arg}; + } + } + } + + # append other command line arguments not recognized by BNG + if ( defined $params->{param} ) + { push @args, split " ", $params->{param}; } + + # exit here if we're not executing + return '' if $BNGModel::NO_EXEC; + + if ( $model->Params->{no_nfsim} ) + { # don't execute NFsim if no_nfsim parameter is true + send_warning( "simulate_nf(): skipping simulation, 'no-nfsim' flag is true."); + return ''; + } + + + # continue with simulation... +# print "Netfree simulation using NFsim\n"; + my $program; + unless ( $program = findExec("NFsim") ) + { return "Could not find executable NFsim"; } + my @command = ($program); + + # Write BNG xml file + $model->writeXML( {'prefix'=>$prefix} ); + + # Define command line + push @command, "-xml", "${prefix}.xml", "-o", "${prefix}.gdat"; + + # Append the run time and output intervals + my $t_start; + if (defined $params->{t_start}) + { + $t_start = $params->{t_start}; + $model->Time($t_start); + } + else + { + $t_start = defined $model->Time ? $model->Time : 0; + } + + + unless ($t_start == 0) + { # warn user if t_start > 0 + send_warning("simulate_nf(): NFsim timepoints are reported as time elapsed since t_start=$t_start."); + } + + if ($params->{continue}) + { # warn user that continue is not supported +# send_warning("simulate_nf(): NFsim does not support 'continue' option. NFsim will overwrite any existing trajectories."); + return "NFsim does not support 'continue' option."; + } + + my $t_end; + if ( defined $params->{n_steps} ) + { + my ($n_steps, $t_end); + $n_steps = $params->{n_steps}; + if ( $n_steps < 1 ) + { return "No simulation output requested: set n_steps>0"; } + + if ( defined $params->{t_end} ) + { $t_end = $params->{t_end}; } + else + { return "Parameter t_end must be defined"; } + + unless ( $t_end > $t_start ) + { return "t_end must be greater than t_start."; } + + push @command, "-sim", ($t_end-$t_start), "-oSteps", $n_steps; + } + elsif ( defined $params->{sample_times} ) + { + return "sample_times not supported in this version of NFsim"; + } + else + { + return "No simulation output requested: set n_steps>0"; + } + + + # Append the other command line arguments + push @command, @args; + + + # Run NFsim + print "Running NFsim on ", `hostname`; + printf "full command: %s\n", join(" ", @command); + + # Compute timecourses using nfsim + # start simulator as child process with communication pipes + local ( *Reader, *Writer, *Err ); + my $pid = eval{ open3( \*Writer, \*Reader, \*Err, @command ) }; + if ($@) { return sprintf("%s failed: $@", join(" ", @command)); } + + # remember child PID + $::CHILD_PID = $pid; + print "[simulation PID is: $pid]\n"; + + my $last = ''; + while ( ) + { + print; + $last = $_; + } + ( my @err = ); + + close Writer; + close Reader; + close Err; + waitpid( $pid, 0 ); + + # clear child pid + $::CHILD_PID = undef; + + if (@err) { + print "Error log:\n", @err; + foreach my $e (@err){ + unless ( $e =~ /^\s*WARNING/i ){ + return sprintf("%s did not run successfully.", join(" ", @command)); + } + } + } + + if ( $params->{get_final_state} ) + { # Update final species concentrations to allow trajectory continuation + if (my $err = $model->readNFspecies("${prefix}.species")) + { return $err; } + #if ( $params->{verbose} ) + #{ print $model->SpeciesList->writeBNGL( $model->Concentrations, $model->ParamList ); } + } + else + { + send_warning( "system state was not retrieved following simulate_nf. " + ."To retreive system state, call simulate_nf with option: get_final_state=>1." ); + } + + $model->Time($t_end); + return ''; +} + + + +### +### +### + + + +sub readNFspecies +{ + # This function reads a list of species strings from NFsim output to form a + # canonical species list with correct concentrations. Note that it overwrites + # any existing species. + my $model = shift @_; + my $fname = shift @_; + + my $conc_vec; + if ($model->SpeciesList) + { + $conc_vec = [ (0) x scalar @{$model->SpeciesList->Array} ]; + } + else + { + $conc_vec = []; + # create species list + $model->SpeciesList( SpeciesList->new ); + } + my $slist = $model->SpeciesList; + + # tell SpeciesLabel to use Quasi method for species w/ large number of molecules + my $maxMols = 20; + my $save_maxMols = SpeciesGraph::getSpeciesLabelMethod_MaxMols(); + SpeciesGraph::setSpeciesLabel( SpeciesGraph::getSpeciesLabelMethod(), $maxMols ); + + # Read NFsim species file + print "readNFspecies::Reading from file $fname\n"; + #my $FH; + open(my $FH, "<", $fname) + or return "Couldn't read from file $fname: $!"; + + my $n_spec_read = 0; + my $n_spec_unique = 0; + my $line_num = 0; + while ( my $string = <$FH> ) + { + ++$line_num; + chomp $string; # remove line return + $string =~ s/^\s+//; # remove leading whitespace + $string =~ s/\#.*$//; # remove comments + next unless $string =~ /\S+/; # skip blank lines + + # Read species string + my $sg = SpeciesGraph->new(); + my $err = $sg->readString( \$string, $model->CompartmentList, 1, '^\s+', + $model->MoleculeTypesList ); + if ($err) { return $err." at line $line_num of file $fname"; } + + # Read species concentration - may only be integer value + my $conc; + if ( $string=~ /^\s*(\d+)\s*$/ ) + { $conc = $1; } + else + { return "species concentration must be single integer at line $line_num of file $fname"; } + + # Check if isomorphic to existing species + my $existing_sg = $model->SpeciesList->lookup( $sg ); + if ($existing_sg) + { + # check if the original concentration is zero and if so, add to unique count + if ( $conc_vec->[$existing_sg->Index - 1] == 0 ) { + ++$n_spec_unique; + } + # Add concentration to concentration of existing species + $conc_vec->[$existing_sg->Index - 1] += $conc; + } + else + { + # Create new Species entry in SpeciesList with zero default concentration + my $newspec = $model->SpeciesList->add( $sg, 0 ); + $conc_vec->[ $newspec->Index - 1 ] = $conc; + ++$n_spec_unique; + } + ++$n_spec_read; + } + close $FH; + + $model->Concentrations( $conc_vec ); + printf "Read %d unique species of %d total.\n", $n_spec_unique, $n_spec_read; + + # return SpeciesLable method to original setting + SpeciesGraph::setSpeciesLabel( SpeciesGraph::getSpeciesLabelMethod(), $save_maxMols ); + + return ''; +} + + + +### +### +### + + + +# construct a hybrid particle population (HPP) model +# --Justin, 21mar2011 +sub generate_hybrid_model +{ + my $model = shift; + my $user_options = shift; + + + my $indent = ' '; + my $step_index = 0; + printf "ACTION: generate_hybrid_model( %s )\n", $model->Name; + + + # default options + my $options = + { 'prefix' => undef, + 'suffix' => 'hpp', + 'overwrite' => 0, + 'verbose' => 0, + 'actions' => ['writeXML()'], + 'execute' => 0, + 'safe' => 0 + }; + # get user options + foreach my $opt (keys %$user_options) + { + my $val = $user_options->{$opt}; + if ($opt eq "exact") + { # TODO: temporary patch to allow the old "exact" option + send_warning("The 'exact' option has been renamed 'safe', please use this in the future."); + $opt = "safe"; + } + + unless ( exists $options->{$opt} ) + { return "Unrecognized option $opt in call to generate_hybrid_model"; } + + # overwrite default option + $options->{$opt} = $val; + } + # print options + print "options = \n"; + while ( my ($par,$val) = each %$options ) + { + next unless (defined $val); + if ( ref $val eq 'ARRAY') + { printf( "%12s => %-60s\n", $par, "[array]" ); } + elsif ( ref $val eq 'HASH') + { printf( "%12s => %-60s\n", $par, "{hash}" ); } + elsif ( ref \$val eq 'SCALAR') + { printf( "%12s => %-60s\n", $par, $val ); } + } + + # do nothing if $NO_EXEC is true + return '' if $BNGModel::NO_EXEC; + + # determine HPP model name + # (1) if prefix is defined, try to extract the file basename + # (2) otherwise use the name of the parent model +# my $modelname; +# my $outdir; +# if (defined $options->{prefix}) +# { +# my ($vol,$dir,$filebase) = File::Spec->splitpath($options->{prefix}); +# if ($filebase eq '') +# { return sprintf "Prefix value '%s' does not end with a file basename", $options->{prefix}; } +# $outdir = File::Spec->catpath($vol, $dir); +# $modelname = $filebase; +# } +# else +# { + # $outdir = defined $options->{output_dir} ? $options->{output_dir} : $model->getOutputDir(); +# $modelname = $model->Name; +# } + # add suffix +# $modelname .= "_" . $options->{suffix}; + + + # define prefix +# my $prefix = defined $options->{prefix} ? $options->{prefix} : File::Spec->catfile($outdir, $modelname); + my $prefix = defined $options->{prefix} ? $model->getOutputPrefix( $options->{prefix} ) : $model->getOutputPrefix(); + $prefix .= "_" . $options->{suffix}; + + # define outdir and modelname + my ($vol,$dir,$modelname) = File::Spec->splitpath($prefix); + my $outdir = File::Spec->catpath($vol, $dir); + + # define filename +# my $modelfile = $modelname . ".bngl"; + my $modelfile = $prefix . ".bngl"; + + if ( -e $modelfile ) + { + if ($options->{overwrite}) + { + send_warning( "Overwriting older model file: $modelfile" ); + unlink $modelfile; + } + else + { + return "Model file $modelfile already exists. Set overwrite=>1 option to force overwrite."; + } + } + + # check if a ParamList exists + unless ( defined $model->ParamList ) + { return sprintf "Cannot continue! Model %s does not have a parameter list.", $model->Name; } + + # Check for MoleculeTypes + unless ( defined $model->MoleculeTypesList and %{$model->MoleculeTypesList->MolTypes} ) + { return sprintf "Nothing to do! Model %s has zero molecule type definitions.", $model->Name; } + + # check if a SpeciesList exists + unless ( defined $model->SpeciesList and @{$model->SpeciesList->Array} ) + { return sprintf "Nothing to do! Model %s has zero seed species definitions.", $model->Name; } + + # Check for RxnRules + unless ( defined $model->RxnRules and @{$model->RxnRules} ) + { return sprintf "Nothing to do! Model %s has zero reaction rule definitions.", $model->Name; } + + # check if PopulationTypesList exists + unless ( defined $model->PopulationTypesList and %{$model->PopulationTypesList->MolTypes} ) + { return sprintf "Nothing to do! Model %s has zero population type definitions.", $model->Name; } + + # check if PopulationList exists + unless ( defined $model->PopulationList and @{$model->PopulationList->List} ) + { return sprintf "Nothing to do! Model %s has zero population map definitions.", $model->Name; } + + + # create new model! + my $hybrid_model = BNGModel::new(); + + $hybrid_model->Name( $modelname ); + $hybrid_model->Version( $model->Version ); + $hybrid_model->SubstanceUnits( $model->SubstanceUnits ); + + # copy options + %{$hybrid_model->Options} = %{$model->Options}; + # set prefix + $hybrid_model->Options->{prefix} = $prefix; + #set output_dir + $hybrid_model->setOutputDir($outdir); + + # copy the constants in the parameter list + # NOTE: we'll add observable and functions later + print $indent . "$step_index:Fetching model parameters.. "; ++$step_index; + my $plist_new = $model->ParamList->copyConstant(); + $hybrid_model->ParamList( $plist_new ); + print sprintf "found %d constants and expressions.\n", scalar @{$plist_new->Array}; + + + # Copy compartments + my $clist_new = undef; + if ( defined $model->CompartmentList ) + { + print $indent . "$step_index:Fetching compartments.. "; ++$step_index; + $clist_new = $model->CompartmentList->copy( $plist_new ); + $hybrid_model->CompartmentList( $clist_new ); + print $indent . sprintf "found %d compartments.\n", scalar @{$clist_new->Array}; + send_warning( "generate_hybrid_model() does not support compartments at this time." ) if (@{$clist_new->Array}); + } + + + + # Copying the moleculeTypesList and add population types + print $indent . "$step_index:Fetching molecule types.. "; ++$step_index; + my $mtlist_new = $model->MoleculeTypesList->copy(); + $hybrid_model->MoleculeTypesList( $mtlist_new ); + print sprintf "found %d molecule types.\n", scalar keys %{$mtlist_new->MolTypes}; + { + # Add population types + print $indent . "$step_index:Adding population types.. "; ++$step_index; + foreach my $name ( keys %{$model->PopulationTypesList->MolTypes} ) + { + my $mt = $model->PopulationTypesList->MolTypes->{$name}; + my $mt_copy = $mt->copy(); + $mt_copy->PopulationType(1); + unless ( $mtlist_new->add($mt_copy) ) + { return "PopulationType $name clashes with MoleculeType of the same name"; } + } + print sprintf "found %d population types.\n", scalar keys %{$model->PopulationTypesList->MolTypes}; + } + + + # Copy seed species, replacing with populations if possible, and add empty populations + my $slist_new = SpeciesList::new(); + $hybrid_model->SpeciesList( $slist_new ); + { + print $indent . "$step_index:Fetching seed species..\n"; ++$step_index; + + # loop over species in species list + foreach my $species ( @{$model->SpeciesList->Array} ) + { + my $sg = $species->SpeciesGraph; + my $conc = $species->Concentration; + + # check if this is isomorphic to any of our populations + my $is_pop = 0; + foreach my $pop ( @{$model->PopulationList->List} ) + { + if ( SpeciesGraph::isomorphicTo($species->SpeciesGraph, $pop->SpeciesGraph) ) + { # add the population instead of the speciesGraph + my $sg_copy = $pop->Population->copy(); + $sg_copy->relinkCompartments( $hybrid_model->CompartmentList ); + $slist_new->add( $sg_copy, $species->Concentration ); + $is_pop = 1; + if ( $options->{verbose} ) + { + print $indent.$indent + . sprintf "replaced species %s with population %s.\n", $sg->toString(), $sg_copy->toString(); + } + last; + } + } + unless ($is_pop) + { # this isn't a population, so add SpeciesGraph directly. + my $sg_copy = $species->SpeciesGraph->copy(); + $sg_copy->relinkCompartments( $hybrid_model->CompartmentList ); + $slist_new->add( $sg_copy, $species->Concentration ); + } + } + print $indent . sprintf " ..found %d seed species.\n", scalar @{$slist_new->Array}; + } + + + # Add population species to seed species + { + print $indent . "$step_index:Adding populations with zero counts to seed species..\n"; ++$step_index; + my $zero_pops = 0; + foreach my $pop ( @{$model->PopulationList->List} ) + { + my ($sp) = $slist_new->lookup( $pop->Population ); + unless ( $sp ) + { + my $sg_copy = $pop->Population->copy(); + $sg_copy->relinkCompartments( $hybrid_model->CompartmentList ); + $slist_new->add( $sg_copy, 0 ); + ++$zero_pops; + } + } + print $indent . sprintf " ..added %d populations to seed species list.\n", $zero_pops; + } + + + # Copy the observables and add matches to populations (also register observable names in parameter list) + my $obslist_new = []; + $hybrid_model->Observables( $obslist_new ); + { + print $indent . "$step_index:Fetching observables and adding population matches..\n"; ++$step_index; + # loop over observables + foreach my $obs ( @{$model->Observables} ) + { + my $obs_copy = $obs->copy(); + $obs_copy->relinkCompartments( $hybrid_model->CompartmentList ); + push @{$obslist_new}, $obs_copy; + + # get a parameter that points to this observable + if ( $plist_new->set( $obs_copy->Name, '0', 1, "Observable", $obs_copy) ) + { + my $name = $obs_copy->Name; + return "Observable name $name clashes with previously defined Observable or Parameter"; + } + + # find populations to add to observable + my @add_patterns = (); + foreach my $pop ( @{$model->PopulationList->List} ) + { + my $matches = $obs_copy->match( $pop->SpeciesGraph ); + + if ($matches) + { + my $ii = 0; + while ( $ii < $matches ) + { + push @add_patterns, $pop->Population->copy()->relinkCompartments( $hybrid_model->CompartmentList ); + ++$ii + } + if ( $options->{verbose} ) + { + print $indent.$indent . sprintf "observable '%s': +%d match%s to %s.\n", + $obs_copy->Name, $matches, ($matches>1 ? 'es' : ''), $pop->Population->toString(); + } + } + } + push @{$obs_copy->Patterns}, @add_patterns; + } + print $indent . sprintf " ..found %d observables.\n", scalar @{$obslist_new}; + } + + + # Copy functions + { + print $indent . "$step_index:Fetching functions.. "; ++$step_index; + my $fcn_copies = $model->ParamList->copyFunctions(); + foreach my $fcn ( @$fcn_copies ) + { + $hybrid_model->ParamList->set( $fcn->Name, $fcn->Expr, 0, 'Function', $fcn ); + } + print sprintf "found %d functions.\n", scalar @{$fcn_copies}; + } + + + # Expand rules + my $rxnrules_new = []; + $hybrid_model->RxnRules( $rxnrules_new ); + { + print $indent . "$step_index:Expanding rules with respect to population objects..\n"; ++$step_index; + + # get the species graphs corresponding to each population + my $pop_species = []; + foreach my $pop ( @{$model->PopulationList->List} ) + { push @$pop_species, $pop->SpeciesGraph; } + my $n_popspec = scalar @$pop_species; + + # loop over rules + my $rule_count = 0; + foreach my $rset ( @{$model->RxnRules} ) + { + # NOTE: each element of @RxnRules is an array of rules. + # If a rule is unidirectional, then the array has a single element. + # If a rule is bidirectional, then the array has two elements (forward and reverse) + foreach my $rr (@$rset) + { + # first copy the rule so we don't mess with the orginal model + my $rr_copy = $rr->copy(); + $rr_copy->resetLabels(); + + # apply rule to population species + my $child_rule_list = $rr_copy->expandRule( $pop_species, $model, $hybrid_model, $options ); + foreach my $child_rule ( @$child_rule_list ) + { + push @$rxnrules_new, [$child_rule]; + } + if ( $options->{verbose} ) + { + print $indent.$indent . sprintf "Rule '%s': expanded to %d child rule%s.\n", + $rr_copy->Name, scalar @$child_rule_list, ((scalar @$child_rule_list > 1)?'s':''); + } + ++$rule_count; + } + } + print $indent . sprintf " ..finished processing %d reaction rules.\n", $rule_count; + } + + + # Add population maps to the list of rules + { + print $indent . "$step_index:Fetching population maps.. "; ++$step_index; + foreach my $pop ( @{$model->PopulationList->List} ) + { + # write rule as string + my $rr_string = $pop->MappingRule->toString(); + # remove the linebreak + $rr_string =~ s/\\\s//; + # parse string to create "copy" of rule + my ($rrs, $err) = RxnRule::newRxnRule( $rr_string, $hybrid_model ); + push @$rxnrules_new, $rrs; + } + print sprintf "found %d maps.\n", scalar @{$model->PopulationList->List}; + } + + + # create empty RxnList + print $indent . "$step_index:Creating empty reaction list.\n"; ++$step_index; + my $rxnlist_new = RxnList::new(); + $hybrid_model->RxnList( $rxnlist_new ); + + + # Print hybrid model to file + my $FH; + print $indent . "$step_index:Attempting to write hybrid BNGL.. "; ++$step_index; + unless ( open $FH, '>', $modelfile ) { return "Couldn't write to $modelfile: $!\n"; } + + print $FH $hybrid_model->writeBNGL( {'format'=>'bngl', 'include_model'=>1,'include_network'=>0, + 'pretty_formatting'=>1,'evaluate_expressions'=>0 } ); + # writing actions! + if ( @{$options->{actions}} ) + { + my $action_string = "\n\n## model actions ##\n"; + foreach my $action ( @{$options->{actions}} ) + { + $action_string .= "$action\n"; + } + $action_string .= "\n"; + print $FH $action_string; + } + close $FH; + + + print "done.\n"; + print "Wrote hybrid model to file $modelfile.\n"; + + + if ( $options->{execute} ) + { # execute actions + $BNGModel::GLOBAL_MODEL = $hybrid_model; + my $errors = []; + foreach my $action ( @{$options->{actions}} ) + { + my $action_string = "\$hybrid_model->$action"; + my $err = eval "$action_string"; + if ($@) { warn $@; } + if ($err) { push @$errors, $err; } + } + $BNGModel::GLOBAL_MODEL = $model; + if (@$errors) { return join "\n", $errors; } + } + + return ''; +} + + + +### +### +### + + +sub bifurcate +{ + my $model = shift @_; + my $params = @_ ? shift @_ : {}; + + my @scanfiles = (); + my ($i,$j,$err); + + # don't reset concentrations after each run + $params->{reset_conc} = 0; + + # update user + printf "ACTION: bifurcate(par: %s, min: %s, max: %s, n_pts: %s, log: %s)\n", + (exists $params->{parameter} ? $params->{parameter} : "UNKNOWN"), + (exists $params->{par_min} ? $params->{par_min} : "UNKNOWN"), + (exists $params->{par_max} ? $params->{par_max} : "UNKNOWN"), + (exists $params->{n_scan_pts} ? $params->{n_scan_pts} : "UNKNOWN"), + (exists $params->{log_scale} ? $params->{log_scale} : 0); + + # forward scan + if (exists $params->{suffix}){ $params->{suffix} .= "_forward"; } + else{ $params->{suffix} = "forward"; } + $err = $model->parameter_scan( $params ); + if ($err){ return $err } + push @scanfiles, $params->{scanfile}; # 'outfile' param set in parameter_scan + + # backwards scan + $params->{suffix} =~ s/forward/backward/; + my $par_min = $params->{par_min}; + $params->{par_min} = $params->{par_max}; + $params->{par_max} = $par_min; + $err = $model->parameter_scan( $params ); + if ($err){ return $err } + push @scanfiles, $params->{scanfile}; # 'outfile' param set in parameter_scan + + # extract forward scan data + my @forward; + open FILE, $scanfiles[0] or die "Couldn't open file: $!"; + my $line = ; # first line + chomp $line; + $line =~ s/^\s*#\s+//; # remove leading # and whitespace + my @header = split('\s+',$line); # scan param + observable names + $i = 0; + while ($line = ){ + chomp $line; + $line =~ s/^\s*//; # remove leading whitespace + my @tmp = split('\s+',$line); + for ($j=0;$j < scalar(@tmp);$j++){ + $forward[$i][$j] = $tmp[$j]; + } + $i++; + } + close FILE; + + # extract backward scan data + my @backward; + open FILE, $scanfiles[1] or die "Couldn't open file: $!"; + $line = ; # first line + $i = 0; + while ($line = ){ + chomp $line; + $line =~ s/^\s*//; # remove leading whitespace + my @tmp = split('\s+',$line); + for ($j=0;$j < scalar(@tmp);$j++){ + $backward[$i][$j] = $tmp[$j]; + } + $i++; + } + close FILE; + + # generate one output file for each observable + my $prefix = $scanfiles[0]; + $prefix =~ s/_forward.scan$/_bifurcation_/; + for (my $j=1;$j < scalar(@header);$j++){ + open FILE, '>', ($prefix . $header[$j] . ".scan") or die "Couldn't open file: $!"; + printf FILE "# %+14s %+16s %+16s\n",$header[0],"$header[$j]_fwd","$header[$j]_bwd"; + for (my $i=0;$i < scalar(@forward);$i++){ + printf FILE "%16.8e %16.8e %16.8e\n",$forward[$i][0],$forward[$i][$j],$backward[scalar(@forward)-1-$i][$j]; + } + close FILE; + } + + # delete scan files and return + unlink @scanfiles; + return; +} + + + +### +### +### + + +sub parameter_scan +{ + use POSIX; + use List::Util qw[min max]; + my $model = shift @_; + my $params = @_ ? shift @_ : {}; + + # define default params + my $default_params = { 'prefix' => $model->getOutputPrefix(), + 'log_scale' => 0, + 'reset_conc' => 1 + }; + + # copy default values for undefined keys + while ( my ($key, $val) = each %$default_params ) + { + unless ( defined $params->{$key} ) + { $params->{$key} = $val; } + } + + # If resetting concentrations, don't need to read in final state + # (important for NFsim simulations, where read can be expensive) + if ( $params->{'reset_conc'} ){ + $params->{'get_final_state'} = 0; + } + + # Output prefix + $params->{prefix} = $model->getOutputPrefix($params->{prefix}); + + # check for required parameters + unless ( defined $params->{parameter} ) + { return "Error in parameter_scan: 'parameter' is not defined."; } + # check that parameter is defined + (my $param, my $err)= $model->ParamList->lookup($params->{parameter}); + if ($err) { return ($err);} + + unless ( defined $params->{par_scan_vals} ){ + + unless ( defined $params->{par_min} ) + { return "Error in parameter_scan: 'par_min' must be defined if 'par_scan_vals' is not."; } + + unless ( defined $params->{par_max} ) + { return "Error in parameter_scan: 'par_max' must be defined if 'par_scan_vals' is not."; } + + unless ( defined $params->{n_scan_pts} ) + { return "Error in parameter_scan: 'n_scan_pts' must be defined if 'par_scan_vals' is not."; } + + if ($params->{par_max} == $params->{par_min}){ + if ($params->{n_scan_pts} < 1){ + return "Error in parameter_scan: 'n_scan_pts' must be >= 1 if 'par_max' = 'par_min'."; + } + } + elsif ($params->{n_scan_pts} <= 1){ + return "Error in parameter_scan: 'n_scan_pts' must be > 1 if 'par_max' != 'par_min'."; + } + } + + # defined min/max takes precedence over par_scan_vals + if ( defined $params->{par_min} and defined $params->{par_max} and defined $params->{n_scan_pts} ){ + # define parameter scan range + my $par_min = $params->{log_scale} ? log $params->{par_min} : $params->{par_min}; + my $par_max = $params->{log_scale} ? log $params->{par_max} : $params->{par_max}; + my $delta = ($par_max - $par_min) / ($params->{n_scan_pts} - 1); # note that this may be negative if par_max < par_min (not a problem) + + # add parameter values to 'par_scan_vals' + $params->{par_scan_vals} = (); + for ( my $k = 0; $k < $params->{n_scan_pts}; ++$k ){ + my $par_value = $par_min + $k*$delta; + if ( $params->{log_scale} ) + { $par_value = exp $par_value; } + push @{$params->{par_scan_vals}}, $par_value; + } + } + + # array of parameter scan values + my @par_scan_vals = @{$params->{par_scan_vals}}; + + # update user +# printf "ACTION: parameter_scan(par: $params->{parameter}, min: $params->{par_min}, max: $params->{par_max}, "; +# printf "n_pts: $params->{n_scan_pts}, log: $params->{log_scale})\n"; + printf "ACTION: parameter_scan( )\n"; + + # define basename for scan results + my $basename = $params->{prefix}; + if ( $params->{suffix} ) + { $basename .= "_" . $params->{suffix}; } + else + { $basename .= "_" . $params->{parameter}; } + + # define working directory for simulation data + my $workdir = $basename; + # define output file for parameter scan results + my $outfile = $basename . ".scan"; + # define file prefix for output results + my ($vol, $dir, $file_prefix) = File::Spec->splitpath( $basename ); + + # create working directory + if (-d $workdir) + { # delete working directory + my $all_files = File::Spec->catfile( ($workdir), '*' ); + unlink <$all_files>; + #system "rm -r $workdir"; + } + else + { mkdir $workdir; } + + # remember concentrations! + $model->saveConcentrations("SCAN"); + + # loop over scan points + if(!(defined $params->{parallel}) or $params->{parallel}==0) + { + for ( my $k = 0; $k < @par_scan_vals; ++$k ) + { + + # define prefix + my $local_prefix = File::Spec->catfile( ($workdir), sprintf("%s_%05d", $file_prefix, $k+1) ); + + # define parameter value + my $par_value = $par_scan_vals[$k]; + + # set parameter + $model->setParameter( $params->{parameter}, $par_value ); + + # reset concentrations + if ( $params->{reset_conc} ){ + $model->resetConcentrations("SCAN"); + } + + # define local params + my $local_params; + %$local_params = %$params; + $local_params->{prefix} = $local_prefix; + delete $local_params->{suffix}; + + # run simulation + my $err; + if($params->{method} eq "protocol") + { + + $err = $model->simulate_protocol($local_params); + } + else + { + $err = $model->simulate( $local_params ); + } + + if ( $err ) + { # return error message + $err = "Error in parameter_scan (step " . ($k+1) . "): $err"; + return $err; + } + } + } + + if((defined $params->{parallel}) and $params->{parallel}==1) + { + my $num_cores = $params->{num_cores}; + my $num_pts = scalar(@par_scan_vals); + my $num_batches = ceil($num_pts/$num_cores); + for my $batch (0..$num_cores-1) + { + if(fork==0) + { + my $end_point = min($num_batches*($batch+1)-1,$num_pts-1); + for my $k($num_batches*$batch .. $num_batches*($batch+1)-1) + { + my $local_prefix = File::Spec->catfile( ($workdir), sprintf("%s_%05d", $file_prefix, $k+1) ); + # define parameter value + my $par_value = $par_scan_vals[$k]; + # set parameter + $model->setParameter( $params->{parameter}, $par_value ); + #reset concentrations + if ( $params->{reset_conc} ){ + $model->resetConcentrations("SCAN"); + } + # define local params + my $local_params; + %$local_params = %$params; + $local_params->{prefix} = $local_prefix; + delete $local_params->{suffix}; + # run simulation + my $err = $model->simulate( $local_params ); + if ( $err ) + { # return error message + $err = "Error in parameter_scan (step " . ($k+1) . "): $err"; + return $err; + } + } + exit; + } + } + while((wait()) > 0) {}; + } + + # recover concentrations + if ( $params->{reset_conc} ){ + $model->resetConcentrations("SCAN"); + } + + # Extract last timepoint from each simulation and write to outfile + my $ofh; + unless ( open $ofh, '>', $outfile ) + { return "Error in parameter_scan: problem opening parameter scan output file $outfile"; } + + for ( my $k = 0; $k < @par_scan_vals; ++$k ) + { + my $par_value = $par_scan_vals[$k]; + + # Get data from gdat file + my $data_file = File::Spec->catfile( ($workdir), sprintf("%s_%05d.gdat", $file_prefix, $k+1) ); + print "Extracting observable trajectory from $data_file\n"; + my $ifh; + unless ( open $ifh,'<', $data_file ) + { return "Error in parameter_scan: problem opening observable file $data_file"; } + + # write header + if ( $k == 0 ) + { + my $headline = <$ifh>; + $headline =~ s/^\s*\#//; + my @headers = split ' ', $headline; + shift @headers; + printf $ofh "# %+14s", $params->{parameter}; + foreach my $header (@headers) + { + printf $ofh " %+16s", $header; + } + print $ofh "\n"; + } + + # get last line + my $lastline; + while ( my $linein = <$ifh> ) + { $lastline = $linein; } + + # close input file + close $ifh; + + # extract data and write to output file + my @data = split ' ', $lastline; + my $time = shift @data; + printf $ofh "%16.8e", $par_value; + foreach my $data ( @data ) + { + printf $ofh " %16.8e", $data; + } + print $ofh "\n"; + } + close $ofh; + + # return without error + $params->{scanfile} = $outfile; # in case another method needs this (e.g. 'bifurcate') + return; +} + + + +### +### +### + + + +sub LinearParameterSensitivity +{ + #This function will perform a brute force linear sensitivity analysis + #bumping one parameter at a time according to a user specified bump + #For each parameter, simulations are saved as: + #'netfile_paramname_suffix.(c)(g)dat', where netfile is the .net model file + #and paramname is the bumped parameter name, and c/gdat files have meaning as normal + + ###################### + # TODO: NOT IMPLEMENTED YET!! + #Additional files are written containing the raw sensitivity coefficients + #for each parameter bump + #format: 'netfile_paramname_suffix.(c)(g)sc' + #going across rows is increasing time + #going down columns is increasing species/observable index + #first row is time + #first column is species/observable index + ###################### + + #Starting time assumed to be 0 + + #Input Hash Elements: + #REQUIRED PARAMETERS + #net_file: the base .net model to work with; string; + #t_end: the end simulation time; real; + #OPTIONAL PARAMETERS + #bump: the percentage parameter bump; real; default 5% + #inp_ppert: model input parameter perturbations; hash{pnames=>array,pvalues=>array}; + #default empty + #inp_cpert: model input concentration perturbations; hash{cnames=>array,cvalues=>array}; + #default empty + #stochast: simulate_ssa (1) or simulate_ode (0) is used; boolean; default 0 (ode) + #CANNOT HANDLE simulate_ssa CURRENTLY + #sparse: use sparse methods for integration?; boolean; 1 + #atol: absolute tolerance for simulate_ode; real; 1e-8 + #rtol: relative tolerance for simulate_ode; real; 1e-8 + #init_equil: equilibrate the base .net model; boolean; default 1 (true) + #re_equil: equilibrate after each parameter bump but before simulation; boolean; default 1 (true) + #n_steps: the number of evenly spaced time points for sensitivity measures; integer; + #default 50 + #suffix: added to end of filename before extension; string; default "" + + #Variable Declaration and Initialization + use strict; + my $model; #the BNG model + my %params; #the input parameter hash table + my $net_file = ""; + my %inp_pert; + my $t_end; + my %readFileinputs; + my %simodeinputs; + my $simname; + my $basemodel = BNGModel->new(); + my $plist; + my $param_name; + my $param_value; + my $new_param_value; + my $pperts; + my $cperts; + my $pert_names; + my $pert_values; +# my $pert_names; +# my $pert_values; + my $newbumpmodel = BNGModel->new(); + my $foo; + my $i; + + #Initialize model and input parameters + + $model = shift; + my $params = shift; + + #Required params + if ( defined( $params->{net_file} ) ) { + $net_file = $params->{net_file}; + } + else { + $net_file = $model->getOutputPrefix(); + } + if ( defined( $params->{t_end} ) ) { + $t_end = $params->{t_end}; + } + else { + return ("t_end not defined"); + } + + #Optional params + my $bump = ( defined( $params->{bump} ) ) ? $params->{bump} : 5; + my $stochast = ( defined( $params->{stochast} ) ) ? $params->{stochast} : 0; + my $sparse = ( defined( $params->{sparse} ) ) ? $params->{sparse} : 1; + my $atol = ( defined( $params->{atol} ) ) ? $params->{atol} : 1e-8; + my $rtol = ( defined( $params->{rtol} ) ) ? $params->{rtol} : 1e-8; + my $init_equil = + ( defined( $params->{init_equil} ) ) ? $params->{init_equil} : 1; + my $t_equil = ( defined( $params->{t_equil} ) ) ? $params->{t_equil} : 1e6; + my $re_equil = ( defined( $params->{re_equil} ) ) ? $params->{re_equil} : 1; + my $n_steps = ( defined( $params->{n_steps} ) ) ? $params->{n_steps} : 50; + my $suffix = ( defined( $params->{suffix} ) ) ? $params->{suffix} : ""; + + #Run base case simulation + %readFileinputs = ( file => "$net_file.net" ); + $basemodel->readFile( \%readFileinputs ); + + #if initial equilibration is required + if ($init_equil) { + $simname = "_baseequil_"; + %simodeinputs = ( + prefix => "$net_file$simname$suffix", + t_end => $t_equil, + sparse => $sparse, + n_steps => $n_steps, + steady_state => 1, + atol => $atol, + rtol => $rtol + ); + $basemodel->simulate_ode( \%simodeinputs ); + } + $simname = "_basecase_"; + %simodeinputs = ( + prefix => "$net_file$simname$suffix", + t_end => $t_end, + sparse => $sparse, + n_steps => $n_steps, + steady_state => 0, + atol => $atol, + rtol => $rtol + ); + + #Implement input perturbations + if ( defined( $params->{inp_ppert} ) ) { + $pperts = $params->{inp_ppert}; + $pert_names = $pperts->{pnames}; + $pert_values = $pperts->{pvalues}; + $i = 0; + while ( $pert_names->[$i] ) { + $param_name = $pert_names->[$i]; + $param_value = $pert_values->[$i]; + $basemodel->setParameter( $param_name, $param_value ); + $i = $i + 1; + } + } + if ( defined( $params->{inp_cpert} ) ) { + $cperts = $params->{inp_cpert}; + $pert_names = $cperts->{cnames}; + $pert_values = $cperts->{cvalues}; + $i = 0; + while ( $pert_names->[$i] ) { + $param_name = $pert_names->[$i]; + $param_value = $pert_values->[$i]; + $basemodel->setConcentration( $param_name, $param_value ); + $i = $i + 1; + } + } + $basemodel->simulate_ode( \%simodeinputs ); + + $plist = $basemodel->ParamList; + + #For every parameter in the model + foreach my $model_param ( @{ $plist->Array } ) + { + $param_name = $model_param->Name; + $param_value = $model_param->evaluate(); + $new_param_value = $param_value * ( 1 + $bump / 100 ); + + #Get fresh model and bump parameter + $newbumpmodel->readFile( \%readFileinputs ); + $newbumpmodel->setParameter( $param_name, $new_param_value ); + + #Reequilibrate + if ($re_equil) { + $simname = "equil_${param_name}"; + %simodeinputs = ( prefix => "${net_file}_${simname}_${suffix}", + t_end => $t_equil, + sparse => $sparse, + n_steps => $n_steps, + steady_state => 1, + atol => $atol, + rtol => $rtol + ); + $newbumpmodel->simulate_ode( \%simodeinputs ); + } + + #Implement input and run simulation + $simname = $param_name; + %simodeinputs = ( + prefix => "${net_file}_${simname}_${suffix}", + t_end => $t_end, + sparse => $sparse, + n_steps => $n_steps, + steady_state => 0, + atol => $atol, + rtol => $rtol + ); + if ( defined( $params->{inp_ppert} ) ) { + $pperts = $params->{inp_ppert}; + $pert_names = $pperts->{pnames}; + $pert_values = $pperts->{pvalues}; + $i = 0; + while ( $pert_names->[$i] ) { + $param_name = $pert_names->[$i]; + $param_value = $pert_values->[$i]; + $newbumpmodel->setParameter( $param_name, $param_value ); + $i = $i + 1; + } + } + if ( defined( $params->{inp_cpert} ) ) { + $cperts = $params->{inp_cpert}; + $pert_names = $cperts->{cnames}; + $pert_values = $cperts->{cvalues}; + $i = 0; + while ( $pert_names->[$i] ) { + $param_name = $pert_names->[$i]; + $param_value = $pert_values->[$i]; + $newbumpmodel->setConcentration( $param_name, $param_value ); + $i = $i + 1; + } + } + $newbumpmodel->simulate_ode( \%simodeinputs ); + + #Evaluate sensitivities and write to file + + #Get ready for next bump + $newbumpmodel = BNGModel->new(); + } + + +} + +### +### +### + +1; diff --git a/libvcell/vcell_install/bionetgen/Perl2/BNGMessages.pm b/libvcell/vcell_install/bionetgen/Perl2/BNGMessages.pm new file mode 100644 index 0000000..c6e4a15 --- /dev/null +++ b/libvcell/vcell_install/bionetgen/Perl2/BNGMessages.pm @@ -0,0 +1,46 @@ +package BNGMessages; +use strict; +use warnings; + +use Class::Struct; + +use Exporter 'import'; +our @EXPORT_OK = qw(error warning message); + +struct BNGMessages => { + errors=> '%', + messages=> '%', + warnings=> '%', + lasterror=> '$' +}; + +#begin error +sub error{ + my @msgs= @_; + print STDERR "ABORT: "; + for my $msg (@msgs){ + print STDERR $msg,"\n"; + } + exit(1); +} +#end error + +#begin warning +sub warning{ + my @msgs= @_; + print STDOUT "WARNING: "; + for my $msg (@msgs){ + print STDOUT $msg,"\n"; + } +} +#end warning + +#begin message +sub message{ + my @msgs= @_; + for my $msg (@msgs){ + print STDOUT $msg unless (BNGOptions::GetBNGOptions()->config->{silent}); + } +} +#end message +1; \ No newline at end of file diff --git a/libvcell/vcell_install/bionetgen/Perl2/BNGModel.pm b/libvcell/vcell_install/bionetgen/Perl2/BNGModel.pm new file mode 100644 index 0000000..67b8bb7 --- /dev/null +++ b/libvcell/vcell_install/bionetgen/Perl2/BNGModel.pm @@ -0,0 +1,2643 @@ +package BNGModel; + +# BioNetGen : rule-based modeling language and simulation platform +# +# Copyright (C) 2006,2009,2012,2014 by +# +# James R. Faeder (faeder at pitt dot edu) +# Justin S. Hogg (justinshogg at gmail dot com) +# Leonard A. Harris (lh64 at cornell dot com) +# John A. P. Sekar (johnarul dot sekar at gmail dot com) +# Jose Juan Tapia (jjtapia at gmail dot com) +# Arshi Arora +# Dipak Barua +# +# 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 3 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, see . + + +# pragmas +use strict; +use warnings; +no warnings 'redefine'; + +# Perl Modules +use Class::Struct; +use FindBin; +use lib $FindBin::Bin; +use File::Spec; +use File::Spec::Win32; +use POSIX ("floor", "ceil"); +use Scalar::Util ("looks_like_number"); +use Config; + +use Cwd; + +# BNGOutput contains BNGModel methods related to third-party output +# e.g. writeXML, writeSBML, writeMfile, writeMexfile, toSSC... +# Note that .NET and .BNGL writer methods are contained in THIS file. +use BNGOutput; + +# BNGAction contains BNGModel action methods +# e.g. simulate, simulate_pla, simulate_nf, simulate_psa, parameter_scan, generate_hybrid_model... +# Note that some core actions are contained here: generate_network, setParameter, etc. +use BNGAction; + +# BNG Modules +use Cache; +use BNGUtils; +use MoleculeTypesList; +use ParamList; +use Function; +use Compartment; +use CompartmentList; +use SpeciesList; +use RxnRule; +use EnergyPattern; +use Observable; +use PopulationList; + + +# A place to store a reference to the current active model. +# Useful when other classes need to find the model. +$BNGModel::GLOBAL_MODEL = undef; + +# Global package variables +my $NO_EXEC = 0; # Prevents execution of functions to allow file syntax checking +my $HAVE_PS = 0; # Set to 0 for MS Windows systems with no ps command - disables + # reporting of memory usage at each iteration of network generation + +# Structure containing BioNetGen model data +struct BNGModel => +{ + Name => '$', + Time => '$', + Concentrations => '@', + MoleculeTypesList => 'MoleculeTypesList', + SpeciesList => 'SpeciesList', + SeedSpeciesList => 'SpeciesList', + RxnList => 'RxnList', + RxnRules => '@', + ParamList => 'ParamList', + Observables => '@', + EnergyPatterns => '@', # for energy BNG only: Holds a list of energy patterns + CompartmentList => 'CompartmentList', # list of reaction compartments (volumes and surfaces) + PopulationTypesList => 'MoleculeTypesList', # list of population molecule types + PopulationList => 'PopulationList', # list of population species + SubstanceUnits => '$', + UpdateNet => '$', # This variable is set to force update of NET file before simulation. + Version => '$', # Indicates set of version requirements- output to BNGL and NET files + Options => '%', # Options used to control behavior of model and associated methods + Params => '%', # run-time parameters (not to be saved) + ParameterCache => 'Cache', + ConcentrationCache => 'Cache', + VizGraphs => '$', + simulation_protocol => '@', +}; + + + +### +### +### + + + +# Initialize BNGModel data structures +sub initialize +{ + my $model = shift @_; + + $model->Name(''); + $model->Version(''); + $model->Time(0); + $model->UpdateNet(0); + $model->ParamList( ParamList->new() ); + $model->MoleculeTypesList( MoleculeTypesList->new('StrictTyping'=>0) ); + $model->PopulationTypesList( MoleculeTypesList->new('StrictTyping'=>0) ); + $model->PopulationList( PopulationList->new() ); + $model->CompartmentList( CompartmentList->new('Used'=>0) ); + $model->SpeciesList( SpeciesList->new() ); + $model->RxnList( RxnList->new('SpeciesList'=>$model->SpeciesList) ); + $model->SubstanceUnits(''); + $model->ConcentrationCache( Cache->new() ); + $model->ParameterCache( Cache->new() ); +} + + +# read Model from file +# $err = $model->readModel({file=>FILENAME}) +sub readModel +{ + my $model = shift @_; + my $user_args = @_ ? shift @_ : {}; + + my %args = (); + # copy user_params into pass_params structures + while ( my ($key,$val) = each %$user_args ) + { $args{$key} = $val; } + + # writeFile will generate the output + return $model->readFile( \%args ); +} + + +# read Network from file +# $err = $model->readModel({file=>FILENAME}) +sub readNetwork +{ + my $model = shift @_; + my $user_args = @_ ? shift @_ : {}; + + my %args = (); + # copy user_params into pass_params structures + while ( my ($key,$val) = each %$user_args ) + { $args{$key} = $val; } + + # writeFile will generate the output + return $model->readFile( \%args ); +} + +sub readSBML +{ + my $model = shift @_; + my $filepath = shift @_; + unless ( -e $filepath ) + { return 1, "Could not find '$filepath'"; } + my ($vol, $dir, $filename) = File::Spec->splitpath( $filepath ); + $filename =~ s/\.xml//; + my $outfile = File::Spec->catpath('', $model->getOutputDir(), $filename.'.bngl'); + my $user_args = @_ ? shift @_ : {}; + + # Collect user arguments + my %args = (); + while ( my ($key,$val) = each %$user_args ) + { + $args{$key} = $val; +# printf "$key=>$val\n"; + } + + # Find program and save path to directory + my $program; + unless ( $program = findExec("sbmlTranslator") ) + { return 1, "Could not find executable 'sbmlTranslator'"; } + ($vol, $dir, my $bin) = File::Spec->splitpath( $program ); + my $bindir = File::Spec->catpath($vol, $dir); + + # Begin writing command: start with 'program' + my $cmd = $program; + $cmd .= ' -i "' . $filepath .'"'; + $cmd .= ' -o "' . $outfile . '"'; + if ($args{"atomize"}){ + $cmd .= ' -a'; + } + + # Run the translator + printf "SBML translation: $cmd\n"; + system($cmd); + + # Return full path to generated BNGL file + return 0, $outfile +} + + +# Read bionetgen data in blocks enclosed by begin param end param +# lines. Prevents overwriting of variables possible with eval. +# +# To do: +# 1. Receive a valid list of parameter names to be read +# 2. Check syntax of lines- this is currently done when parameter is +# handled. Some basic checks could be done here. +# +# Lines between begin and end commands are put into arrays with the name given +# by the block name +{ + + my ($filename, $line_number, $file_data); + my (@filename_stack, @line_number_stack, @file_data_stack, @params_stack); + my $level = -1; + my $MAX_LEVEL = 10; # Sets maximum level of allowed recursion + my %bngdata; + my $t_start; + my $stdout_handle; + + sub readFile + { + # get arguments + my $model = shift @_; + my $params = @_ ? shift @_ : {}; + + # supported blocks + my %blocks = ( + 'parameters' => 1, + 'compartments' => 1, + 'molecule types' => 1, + 'species' => 1, + 'seed species' => 1, + 'observables' => 1, + 'functions' => 1, + 'energy patterns' => 1, + 'population types' => 1, + 'population maps' => 1, + 'reaction rules' => 1, + 'reactions' => 1, + 'groups' => 1, + 'actions' => 1, + ); + + # user-specified list of blocks to read + if (exists $params->{blocks}){ + my %tmp; + foreach my $block (@{$params->{blocks}}){ + $tmp{$block} = 1; + } + foreach (keys %blocks){ + unless (exists $tmp{$_}){ + $blocks{$_} = 0; + } + } + } + + # a place for error messages + my $err; + + # get the filename + my $filename = exists $params->{file} ? $params->{file} : undef; + unless ( defined $filename ) + { # Filename argument is mandatory + $err = errgen( "'file' parameter is required for action readFile()" ); + goto EXIT; + } + + # if file path is relative, change Unix path to Windows path, and vice versa, + # based on OS (improves cross-platform portability --LAH) + if ( not File::Spec::Win32->file_name_is_absolute( $filename ) ){ + if ($Config{myarchname} =~ /MSWin32/) + { $filename =~ s/\//\\/g; } + else + { $filename =~ s/\\/\//g; } + } + + # increment level + ++$level; + if ($level > $MAX_LEVEL) + { + $err = errgen( "Recursion level exceeds maximum of $MAX_LEVEL" ); + goto EXIT; + } + + # Top level stuff + if ($level==0) + { + # get start time + $t_start = cpu_time(0); + + # set model update flag + $model->UpdateNet(1); + + # set model name + if ($model->Name eq '') + { + if ( $params->{basename} ) + { # set model name to basename + $model->Name( $params->{basename} ); + } + else + { # determine model basename from filename + my ($vol, $dir, $fn) = File::Spec->splitpath( $filename ); + + my $basename; + # file = basename.ext + if ( $fn =~ /^(.+)\.([^\.]+)$/ ) + { $basename = $1; } + # file = basename + elsif ( $fn =~ /^([^\.]+)$/ ) + { $basename = $1; } + # file = ??? + else + { $basename = $fn; } + + $model->Name($basename); + } + } + + # set model parameters + $model->Params($params); + + # set output directory + unless ( defined $model->Params->{output_dir} ) + { # default is current directory + $model->setOutputDir(); + } + + # set up log file, if needed + if ( $model->Params->{logging} ) + { + # generate logfile name + my $logfilename = $model->getOutputPrefix() . ".log" ; + # remember where to find STDOUT + unless( open $stdout_handle, ">&STDOUT" ) + { $err = "Problem finding handle for STDOUT: $!"; goto EXIT; } + # redirect STDOUT to logfile + unless ( open STDOUT, '>', $logfilename ) + { $err = "Problem redirecting STDOUT to logfile: $!";; goto EXIT; } + } + + # turn off output buffering on STDOUT + select STDOUT; $| = 1; + + # Say Hello to the user + printf "BioNetGen version %s\n", BNGversion(); + } + elsif ($level > 0) + { + # save state of previous level on stacks + push @filename_stack, $filename; + push @file_data_stack, $file_data; + push @line_number_stack, $line_number; + push @params_stack, $model->Params; + + # inherit params from previous level + $model->Params( {%{$model->Params}} ); + # overwrite any params that were explicitly changed + while ( my ($opt,$val) = each %$params ) + { $model->Params->{$opt} = $val; } + } + + # SBML translator + if ( $filename =~ /\.xml$/ ) + { + if ( $model->Params->{no_atomizer} ) + { + send_warning( "readFile(): BNG processing was halted. Attempted to import XML file with 'no-atomizer' flag activated."); + exit(0); + } + my $out; + ($err, $out) = $model->readSBML($filename,$model->Params); + if ($err){ + $err = $out; + goto EXIT; + } + $filename = $out + # Generated BNGL file will now be read in below + } + + # Read BNGL or NET file + if ( $filename =~ /\.bngl$/ || $filename =~ /\.net$/ ) + { + # Read BNG model data + print "Reading from file $filename (level $level)\n"; + unless( open FILE, '<', $filename ) + { + unless (File::Spec->file_name_is_absolute( $filename )){ + $filename = File::Spec->rel2abs( $filename ); + } + $err = "Couldn't read from file $filename: $!"; + goto EXIT; + } + # read all lines of the file into an array at $file_data + $file_data = []; + # close file + close FILE; + + + # Read data from file into data hash + $line_number = 0; + my $begin_model = 0; + my $in_model = 1; + while ( my $string = get_line() ) + { + # chop leading spaces + $string =~ s/^\s+//; + + if ( $string =~ /^begin\s+model\s*$/ ) + { + ++$begin_model; + if ( $begin_model > 1 ) + { + $err = errgen("Only one model definition allowed per file"); + goto EXIT; + } + $in_model = 1; + next; + } + elsif ( $string =~ /^end\s+model\s*$/ ) + { + unless ($in_model) + { + $err = errgen("end model encountered without enclosing begin model"); + goto EXIT; + } + $in_model = 0; + next; + } + + # Process multi-line block + if ( $string =~ s/^begin\s*// ) + { + # get block name + my $name = $string; + # Remove trailing white space + $name =~ s/\s*$//; + # Remove repeated white space + $name =~ s/\s+/ /g; + + unless ($in_model or ($name eq 'actions') or ($name eq 'protocol')) + { + $err = errgen("$name cannot be defined outside of a model"); + goto EXIT; + } + + # Read block data + my $block_dat; + ( $block_dat, $err ) = read_block_array($name); + if ($err) { goto EXIT; } +# $bngdata{$name} = 1; + + # Move on if block has been suppressed by the user + # (if the block name is not recognized, continue so an error will be thrown) + if (exists $blocks{$name} and $blocks{$name}==0) { next; } + + ### Read Parameters Block + if ( $name eq 'parameters' ) + { + # Read model parameters + my $plast = $model->ParamList->getNumParams(); + my ($entry, $lno); + foreach my $line ( @$block_dat ) + { + ($entry, $lno) = @$line; + $err = $model->ParamList->readString($entry); + if ($err) { $err = errgen( $err, $lno ); goto EXIT; } + } + # check parameter list + if ( $err = $model->ParamList->check() ) + { + $err = errgen( $err, $lno ); + goto EXIT; + } + # sort parameters + if ( $err = $model->ParamList->sort() ) + { + $err = errgen( $err, $lno ); + goto EXIT; + } + + # AS-2022 + # warn user if the value is negative + foreach my $param ( @{$model->ParamList->Array} ) + { + if ( $param->Expr->evaluate($model->ParamList) < 0 ) { + printf "Warning: Parameter %s is set to a negative value: %s\n", + ( $param->Name, $param->Expr->evaluate($model->ParamList)); + } + } + # AS + + # update user + printf "Read %d $name.\n", $model->ParamList->getNumParams() - $plast; + } + + + ### Read Functions Block + elsif ( $name eq 'functions' ) + { + # Model functions + my $nread = 0; + my ($entry, $lno); + foreach my $line ( @$block_dat ) + { + ($entry, $lno) = @{$line}; + my $fun = Function->new(); + $err = $fun->readString( $entry, $model ); + if ($err) { $err = errgen( $err, $lno ); goto EXIT; } + ++$nread; + } + + # check paramlist for unresolved dependency, etc + # GIVE warning here, don't terminate! + if ( $err = $model->ParamList->check() ) + { + $err = errgen( $err, $lno ); + print "Warning: $err\n" + ." (if parameter is defined in a subsequent block,\n" + ." then this warning can be safely ignored.)\n"; + } + # update user + printf "Read %d ${name}.\n", $nread; + } + + + ### Read Molecule Types block + elsif ( $name eq 'molecule types' ) + { + # read MoleculeTypes + $model->MoleculeTypesList->StrictTyping(1); + foreach my $line ( @$block_dat ) + { + my ( $entry, $lno ) = @$line; + $err = $model->MoleculeTypesList->readString($entry); + if ($err) { $err = errgen( $err, $lno ); goto EXIT; } + } + # update user + printf "Read %d molecule types.\n", $model->MoleculeTypesList->getNumMolTypes(); + } + + + ### Read Population Types block + elsif ( $name eq 'population types' ) + { + # read PopulationTypes + $model->PopulationTypesList->StrictTyping(1); + foreach my $line ( @$block_dat ) + { + my ( $entry, $lno ) = @$line; + $err = $model->PopulationTypesList->readString($entry); + if ($err) { $err = errgen( $err, $lno ); goto EXIT; } + } + # update user + printf "Read %d population types.\n", $model->PopulationTypesList->getNumMolTypes(); + } + + + ### Read Population Maps block + elsif ( $name eq 'population maps' ) + { + unless ( $model->MoleculeTypesList->StrictTyping ) + { + $err = errgen("A $name block cannot be defined unless molecule types are defined explicitly"); + goto EXIT; + } + # read Population Maps + foreach my $line ( @$block_dat ) + { + my ($entry, $lno) = @$line; + $err = $model->PopulationList->readString($entry,$model); + if ($err) { $err = errgen( $err, $lno ); goto EXIT; } + } + # update user + printf "Read %d population maps.\n", $model->PopulationList->getNumPopulations; + } + + + ### Read Compartments Block + elsif ( $name eq 'compartments' ) + { + # Read Compartments + my ($entry, $lno); + foreach my $line ( @$block_dat ) + { + ($entry, $lno) = @$line; + $err = $model->CompartmentList->readString( $entry, $model->ParamList ); + if ($err) { $err = errgen( $err, $lno ); goto EXIT; } + } + # validate compartments + if ( $err = $model->CompartmentList->validate() ) + { + $err = errgen( $err, $lno ); + goto EXIT; + } + if ($model->CompartmentList->getNumCompartments() > 0){ + # set flag to indicate compartments are being used + $model->CompartmentList->Used(1); + # update user + printf "Read %d compartments.\n", $model->CompartmentList->getNumCompartments; + } + } + + + ### Read Species/Seed Species Block + elsif ( ($name eq 'species') or ($name eq 'seed species') ) + { + # read Species + foreach my $line ( @$block_dat ) + { + my ($entry, $lno) = @$line; + $err = $model->SpeciesList->readString( $entry, $model->ParamList, + $model->CompartmentList, + $model->MoleculeTypesList ); + if ($err) { $err = errgen( $err, $lno ); goto EXIT; } + } + # update user + printf "Read %d species.\n", $model->SpeciesList->getNumSpecies(); + } + + + ### Read Reaction Rules Block + elsif ( $name eq 'reaction rules' ) + { + # Read reaction rules + my $nerr = 0; + #my $rrules = []; + #$model->rxnrules( $rrules ); + my $rrules = $model->RxnRules; + my $counter = 1; + foreach my $line ( @$block_dat ) + { + my ($entry, $lno) = @$line; + # create new rule + (my $rrs, $err) = RxnRule::newRxnRule( $entry, $model, $lno ); + if ($err) + { # some error encountered + $err = errgen( $err, $lno ); + printf "ERROR: $err\n"; + ++$nerr; + } + # check rule name (if given) + elsif ( $rrs->[0]->Name ){ + foreach my $r (@$rrules){ # loop over all existing rules + foreach my $x (@$r){ # consider forward and reverse (if exists) for existing rule (just to be safe) + if ( $rrs->[0]->Name eq $x->Name ){ # duplicate rule name found + $err = "Duplicate rule name detected (\"" . $rrs->[0]->Name . "\")."; + $err = errgen( $err, $lno ); + printf "ERROR: $err\n"; + ++$nerr; + last; + } + } + } + } + unless ($err) + { + # rule is ok + push @$rrules, $rrs; + + # give names, if not defined + unless ( $rrs->[0]->Name ) + { + #$rrs->[0]->Name( 'Rule' . scalar @$rrules ); + my $rname = '_R' . $counter++; + # avoid duplicate names (just to be safe) + for (my $i=0; $i < @$rrules-1; $i++){ + if ($rname eq @$rrules[$i]->[0]->Name){ # duplicate rule name + $rname = '_R' . $counter++; + $i = -1; # start over + } + } + $rrs->[0]->Name( $rname ); + } + if ( @$rrs > 1 ) + { + unless ($rrs->[1]->Name) + { + #$rrs->[1]->Name( 'Rule' . scalar @$rrules . 'r' ); + $rrs->[1]->Name( '_reverse_' . $rrs->[0]->Name); + } + } + } + if ($nerr) + { + $err = "Reaction rule list could not be read because of errors."; + goto EXIT; + } + } + # update user + printf "Read %d reaction rule(s).\n", scalar @{$model->RxnRules}; + } + + + ### Read Reactions Block + elsif ( $name eq 'reactions' ) + { + # Reactions (when reading NET file) + my $rlist = RxnList->new; + foreach my $line ( @{$block_dat} ) + { + my ( $entry, $lno ) = @{$line}; + $err = $rlist->readString( $entry, + $model->SpeciesList, + $model->ParamList ); + if ($err) { $err = errgen( $err, $lno ); goto EXIT; } + } + printf "Read %d reaction(s).\n", scalar( @{$block_dat} ); + $model->RxnList($rlist); + } + + + ### Read Groups Block + elsif ( $name eq 'groups' ) + { + my $iobs = 0; + if ( @{$model->Observables} ) + { # Associate groups with exisiting observables + # my $iobs = 0; + foreach my $line ( @$block_dat ) + { + my ($entry, $lno) = @$line; + + # split into tokens (note: using ' ' is different than / /, see perlfunc) + my @tokens = split ' ', $entry; + + # Skip first entry if it's an index + if ( $tokens[0] =~ /^\d+$/ ) { shift @tokens; } + + if ( $iobs >= @{$model->Observables} ) + { # more groups than observables! + $err = errgen( "More groups than observables", $lno ); + goto EXIT; + } + + # get observable + my $obs = $model->Observables->[$iobs]; + + # Check that Observable and Group names match + my $group_name = @tokens ? shift @tokens : ''; + unless ( $group_name eq $obs->Name ) + { + $err = errgen("Group named '$tokens[0]' is not compatible with any observable", $lno ); + goto EXIT; + } + + # get group weights + my @group_weights = split (/,/, $tokens[0]); + + # Zero the weights (TODO..) + @{$obs->Weights} = (0) x scalar @{$obs->Weights}; + my ($weight, $species_idx); + foreach my $component (@group_weights) + { + if ( $component =~ m/^(\d+)\*(\d+)$/ ) + { + $weight = $1; + $species_idx = $2; + } + elsif ( $component =~ m/^(\d+)$/ ) + { + $weight = 1; + $species_idx = $1; + } + else + { + $err = errgen( "Invalid group entry: $component", $lno ); + goto EXIT; + } + $obs->Weights->[$species_idx] += $weight; + } + ++$iobs; + } + } + else + { # create a dummy observable for each group + send_warning("Found 'groups' block before 'observables': creating observables."); + + # get the number of species + my $n_species = $model->SpeciesList->getNumSpecies(); + + #my $iobs = 0; + foreach my $line ( @$block_dat ) + { + my ($entry, $lno) = @$line; + + # split into tokens (note: using ' ' is different than / /, see perlfunc) + my @tokens = split ' ', $entry; + + # Skip first entry if it's an index + if ( $tokens[0] =~ /^\d+$/ ) { shift @tokens; } + + # Group name is next token + my $group_name = @tokens ? shift @tokens : ''; + unless ( $group_name =~ /^\w+$/ ) + { + $err = errgen("Invalid group name '$group_name'", $lno ); + goto EXIT; + } + + # create dummy observable + my $obs = Observable->new( Name=>$group_name, Patterns=>[], Weights=>[], Type=>"Molecule", Output=>1 ); + push @{$model->Observables}, $obs; + + # Add paramter to observable list + if ( $model->ParamList->set( $obs->Name, "0", 1, "Observable", $obs) ) + { + my $name = $obs->Name; + $err = errgen( "Observable name $name matches previously defined Observable or Parameter", $lno ); + goto EXIT; + } + + # get group weights + my @group_weights = ($tokens[0]) ? split( /,/ , $tokens[0] ) : (); + + # Zero the weights + @{$obs->Weights} = (0) x ($n_species+1); + my ($weight, $species_idx); + foreach my $component (@group_weights) + { + if ( $component =~ /^(\d+)\*(\d+)$/ ) + { + $weight = $1; + $species_idx = $2; + } + elsif ( $component =~ /^(\d+)$/ ) + { + $weight = 1; + $species_idx = $1; + } + else + { + $err = errgen( "Invalid group entry: $component", $lno ); + goto EXIT; + } + $obs->Weights->[$species_idx] += $weight; + } + ++$iobs; + } + } + # update user + printf "Read %d group(s).\n", $iobs; + } + + + ### Read Observables Block + elsif ( $name eq 'observables' ) + { + # Read observables + my ($entry, $lno ); + foreach my $line ( @$block_dat ) + { + ($entry, $lno ) = @$line; + my $obs = Observable->new(); + $err = $obs->readString($entry, $model); + if ($err) + { + $err = errgen( $err, $lno ); + goto EXIT; + } + push @{$model->Observables}, $obs; + } + + # check paramlist for unresolved dependency, etc + # GIVE warning here, don't terminate! + if ( $err = $model->ParamList->check() ) + { + $err = errgen( $err, $lno ); + print "Warning: $err\n" + ." (if parameter is defined in a subsequent block,\n" + ." then this warning can be safely ignored.)\n"; + } + # update user + printf "Read %d observable(s).\n", scalar @{$model->Observables}; + } + + + ### Read Energy Patterns Block + elsif ( $name eq 'energy patterns' ) + { + # read energy patterns + foreach my $line ( @$block_dat ) + { + my ($entry, $lno) = @$line; + my $epatt = EnergyPattern->new(); + $err = $epatt->readString( $entry, $model ); + if ($err) { $err = errgen($err, $lno); goto EXIT; } + push @{$model->EnergyPatterns}, $epatt; + } + # update + printf "Read %d energy patterns(s).\n", scalar @{$model->EnergyPatterns}; + + } + + + ### Read Actions Block + elsif ( $name eq 'actions' ) + { + if ($model->Params->{'skip_actions'}) + { + unless ($model->Params->{'action_skip_warn'}) + { send_warning( err_gen("Skipping actions") ); } + next; + } + # Read actions + foreach my $line ( @$block_dat ) + { + my ($entry, $lno) = @$line; + # Remove (and ignore) leading index from line + $entry =~ s/^\d+\s+//; + # Get action and options + my ($action, $options); + if ( $entry =~ /^\s*(\w+)\s*\((.*)\);?\s*$/ ) + { + $action = $1; + $options = $2; + # replace double quotes with single quotes so that Perl won't + # try to interpret special characters. + $options =~ s/"/'/g; + } + else + { + $err = "Line $entry does not appear to contain a command"; + $err = errgen( $err, $lno ); + } + + # TODO: validate action + # TODO: validate option syntax + + # Perform self-consistency checks before operations are performed on model + if ( $err = $model->ParamList->check() ) + { + $err = errgen($err); + goto EXIT; + } + + # execute action + my $command = sprintf "\$model->%s(%s);", $action, $options; + my $t_start = cpu_time(0); + $err = eval $command; + if ($@) { $err = errgen($@); goto EXIT; } + if ($err) { $err = errgen($err); goto EXIT; } + my $t_elapsed = cpu_time($t_start); + printf "CPU TIME: %s %.2f s.\n", $action, $t_elapsed; + } + } + ### Read protocol Block + elsif ( $name eq 'protocol' ) + { + struct protocol => + { + action => '$', + options => '$', + }; + if ($model->Params->{'skip_actions'}) + { + unless ($model->Params->{'action_skip_warn'}) + { send_warning( err_gen("Skipping actions") ); } + next; + } + my $command_counter = 0; + # Read actions + foreach my $line ( @$block_dat ) + { + my ($entry, $lno) = @$line; + # Remove (and ignore) leading index from line + $entry =~ s/^\d+\s+//; + # Get action and options + my ($action, $options); + if ( $entry =~ /^\s*(\w+)\s*\((.*)\);?\s*$/ ) + { + $action = $1; + $options = $2; + + # replace double quotes with single quotes so that Perl won't + # try to interpret special characters. + $options =~ s/"/'/g; + + my $protocol_command = protocol->new(); + $protocol_command->{action} = $action; + $protocol_command->{options} = $options; + $model->{simulation_protocol}[$command_counter] = $protocol_command; + $command_counter = $command_counter + 1; + } + else + { + $err = "Line $entry does not appear to contain a command"; + $err = errgen( $err, $lno ); + } + # Perform self-consistency checks before operations are performed on model + if ( $err = $model->ParamList->check() ) + { + $err = errgen($err); + goto EXIT; + } + } + } + ### Try to read any other Block type (probably an error) + else + { # exit + $err = errgen("Could not process block type '$name'"); + goto EXIT; + } + } + + elsif ( $string =~ /^\s*(setOption)\s*\((.*)\);?\s*$/ ) + { # special action: setOption(opts) + my $action = $1; + my $options = $2; + + # Perform self-consistency checks before operations are performed on model + if ( $err = $model->ParamList->check() ) + { $err = errgen($err); goto EXIT; } + + # call to methods associated with $model + my $command = '$model->' . $action . '(' . $options . ');'; + $err = eval $command; + if ($@) { $err = errgen($@); goto EXIT; } + if ($err) { $err = errgen($err); goto EXIT; } + } + + elsif ( $string =~ s/^\s*(parameter|param|par)\s+//i ) + { # Define a parameter outside of the Parameter block + unless ($in_model) + { + $err = errgen("Parameter cannot be defined outside of a model"); + goto EXIT; + } + # read parameter + $err = $model->ParamList->readString($string); + if ($err) { $err = errgen($err); goto EXIT; } + } + + elsif ( $string =~ /^\s*(\w+)\s*\((.*)\);?\s*$/ ) + { # execute an Action: "action(options)" + my $action = $1; + my $options = $2; + # replace double quotes with single quotes so that Perl won't + # try to interpret special characters. + $options =~ s/"/'/g; + + if ($model->Params->{'skip_actions'}) + { + unless ($model->Params->{'action_skip_warn'}) + { send_warning( errgen("Skipping actions") ); } + next; + } + + # Perform self-consistency checks before operations are performed on model + if ( $err = $model->ParamList->check() ) + { + $err = errgen($err); + goto EXIT; + } + + # execute action + my $command = sprintf "\$model->%s(%s);", $action, $options; + + my $t_start = cpu_time(0); + $err = eval $command; + if ($@) { $err = errgen($@); goto EXIT; } + if ($err) { $err = errgen($err); goto EXIT; } + my $t_elapsed = cpu_time($t_start); + printf "CPU TIME: %s %.2f s.\n", $action, $t_elapsed; + + } + else + { # Try to execute general PERL code (Dangerous!!) + if ( $model->Params->{allow_perl} ) + { + # General Perl code + eval $string; + if ($@) { $err = errgen($@); goto EXIT; } + } + else + { + send_warning( errgen("Unidentified input! Will not attempt to execute as Perl.") ); + next; + } + } + } + } # end read BNGL or NET + else{ + printf "$filename\n"; + $filename =~ /(\.\w+)$/; + $err = errgen("Cannot read file $filename. Unknown file extension '$1'."); + goto EXIT; + } + + EXIT: + unless ($err) + { + # if we're back at level 0, perform any required actions + if ($level == 0) + + { + if ( $model->Params->{'write_xml'} ) + { $model->writeXML(); } + + if ( $model->Params->{'generate_network'} ) + { $model->generate_network({'overwrite'=>1}); } + + if ( $model->Params->{'write_mfile'} ) + { $model->writeMfile(); } + + if ( $model->Params->{'write_sbml'} ) + { $model->writeSBML(); } + + if ( $model->Params->{'write_SBMLmulti'} ) + { $model->writeSBMLMulti(); } + + } + + # indicate that we're finished + print "Finished processing file $filename.\n"; + if ($level == 0) + { # write time info + printf "CPU TIME: total %.2f s.\n", cpu_time($t_start); + # restore STDOUT + if ($params->{logging}) + { + unless( open STDOUT, ">&", $stdout_handle ) + { $err = "Problem restoring STDOUT: $!\n"; } + } + } + } + + if ($level > 0) + { # retrieve state of previous level from stack + $filename = pop @filename_stack; + $file_data = pop @file_data_stack; + $line_number = pop @line_number_stack; + $model->Params( pop @params_stack ); + } + # drop a level + --$level; + # return with any error messages + return $err; + } + + ### + ### + + sub read_block_array + { + my $name = shift @_; + my @array = (); + + my $got_end = 0; + while ( $_ = get_line() ) + { + # Look for end of block or errors + if ( s/^\s*end\s+// ) + { + my $ename = $_; + $ename =~ s/\s*$//; + $ename =~ s/\s+/ /g; + if ( $ename ne $name ) + { + return ( [], errgen("end $ename does not match begin $name") ); + } + else + { + $got_end = 1; + #print "end at $line_number\n"; + last; + } + } + elsif ( /^\s*begin\s*/ ) + { + return [], errgen("begin block before end of previous block $name"); + } + + # Add declarations from current line + push @array, [$_, $line_number]; + + #print "$_ $line_number\n"; + } + + unless ($got_end) + { return [], errgen("begin $name has no matching end $name"); } + + return [@array]; + } + + ### + ### + + sub errgen + { + my $err = shift @_; + my $lno = @_ ? shift @_ : $line_number; + $err =~ s/[*]/\*/g; + my $reterr = sprintf "%s\n at line $lno", $err; + if (defined $filename) { $reterr .= " of file '$filename'"; } + return $reterr; + } + + ### + ### + + sub get_line + { + my $line; + while ( $line = shift @$file_data ) + { + ++$line_number; + chomp $line; # remove newline character + $line =~ s/\#.*$//; # remove comments + next unless ($line =~ /\S+/); # skip blank lines + while ( $line =~ s/\\\s*$// ) + { # line continuations "\" + last unless (@$file_data); # end if there are no more lines + ++$line_number; + my $nline = shift @$file_data; + chomp $nline; + $nline =~ s/\#.*$//; # remove comments + $line .= $nline; # append to previous line + } + last; + } + return $line; + } + + # END of readFile method +} + + + +### +### +### + + + +# write Model to file (default is BNGL format) +# $err = $model->writeModel({opt=>val,..}) +sub writeModel +{ + use strict; + use warnings; + + my $model = shift @_; + my $user_params = @_ ? shift @_ : {}; + + my %params = ( + 'evaluate_expressions' => 0, + 'format' => 'bngl', + 'include_model' => 1, + 'include_network' => 0, + 'overwrite' => 0, + 'pretty_formatting' => 1, + ); + + # copy user_params into pass_params structures + while ( my ($key,$val) = each %$user_params ) + { $params{$key} = $val; } + + # writeFile will generate the output + return $model->writeFile( \%params ); +} + + +# write Network in NET format +# $err = $model->writeNetwork({opt=>val,..}) +sub writeNetwork +{ + use strict; + use warnings; + + my $model = shift @_; + my $user_params = @_ ? shift @_ : {}; + + my %params = ( + 'evaluate_expressions' => 0, + 'format' => 'net', + 'include_model' => 0, + 'include_network' => 1, + 'overwrite' => 0, + 'pretty_formatting' => 0, + ); + + # copy user_params into pass_params structures + while ( my ($key,$val) = each %$user_params ) + { $params{$key} = $val; } + + # writeFile will generate the output + return $model->writeFile( \%params ); +} + + +# Write Reaction Network to .NET file +# This action will be Deprecated! writeModel and writeNetwork should be used instead +sub writeNET +{ + my $model = shift @_; + my $user_params = @_ ? shift @_ : {}; + + # default parameters + my %params = ( + 'evaluate_expressions' => 1, + 'format' => 'net', + 'include_model' => 1, + 'include_network' => 1, + 'overwrite' => 1, + 'pretty_formatting' => 0, + 'TextReaction' => 0, + 'TextSpecies' => 1, + ); + + # get any user parameters + while ( my ($key,$val) = each %$user_params ) + { $params{$key} = $val; } + + # call writeFile to output the network + return $model->writeFile( \%params ); +} + + +# This is a general method for writing the model and/or network to a file in various formats. +# (This method does the heavy lifting for writeModel and writeNetwork) +# +# $err = $model->writeFile({OPT=>VAL,..}) +# +# OPTIONS: +# evaluate_expressions => 0,1 : evaluate math expressions output as numbers (default=0). +# format => "FORMAT" : select output format, where FORMAT=bngl,net,xml,sbml,ssc (default=net). +# include_model => 0,1 : include model blocks in output file (default=1). +# include_network => 0,1 : include network blocks in output file (default=1). +# overwrite => 0,1 : allow writeFile to overwrite exisiting files (default=0). +# prefix => "string" : set prefix of output file name (default=outdir/MODELNAME). +# pretty_formatting => 0,1 : write output in "pretty" form (default=0). +# suffix => "string" : set suffix of output file name (default=NONE). +# TextReaction => 0,1 : write reactions as BNGL strings (default=0). +# TextSpecies => 0,1 : write species as BNGL string (default=1). +# +# TODO: set up additional formats: SBML, SSC, etc. +sub writeFile +{ + use strict; + use warnings; + + my $model = shift @_; + my $user_params = @_ ? shift @_ : {}; + + my %params = ( + 'evaluate_expressions' => 0, + 'format' => 'net', + 'include_model' => 1, + 'include_network' => 1, + 'overwrite' => 1, + 'prefix' => $model->getOutputPrefix(), + 'pretty_formatting' => 1, + 'suffix' => '', + 'TextReaction' => 0, + 'TextSpecies' => 1, + ); + + # change this to a constant? + my %allowed_formats = ( 'net'=>1, 'bngl'=>1, 'sbml'=>0, 'xml'=>1, 'ssc'=>0 ); + + # copy user_params into params and pass_params structures + foreach my $key ( keys %$user_params ) + { + my $val = $user_params->{$key}; + if ( exists $params{$key} ) + { $params{$key} = $val; } + else + { die "writeFile(): Unrecognized option parameter $key."; } + } + + # check if format is allowed + unless ( $allowed_formats{ $params{'format'} } ) + { + return sprintf( "writeFile() does not currently support '%s' format.", $params{'format'} ); + } + + # check if there's anything to write + unless ( $params{'include_model'} or $params{'include_network'} ) + { + return "writeFile() has nothing to write! Include model or network and try again."; + } + + # check for reactions if we're writing the network + if ( $params{include_network} ) + { + if ( @{$model->RxnList->Array} == 0 ) + { + return "writeFile() was asked to write the network, but no reactions were found.\n" + ."Did you remember to call generate_network() or to define seed species before writing network output?\n"; + } + } + + # do nothing if we're not executing actions + return undef if $NO_EXEC; + + ## Execute the Action ## + # first, build output filename + my $file = $params{prefix}; + unless ( $params{suffix} eq '' ) + { $file .= "_$params{suffix}"; } + $file .= ".$params{format}"; + + # now check if we're overwriting an existing file + if ( -e $file ) + { + if ( $params{overwrite} ) + { + send_warning("writeFile(): Overwriting existing file $file."); + unlink $file; + } + else + { return "writeFile(): file $file exists. Set option overwrite=>1 to overwrite."; } + } + + # make a string that describes outputs to user + my @outputs; + if ( $params{'include_model'} ) + { push @outputs, "model"; } + if ( $params{'include_network'} ) + { push @outputs, "network"; } + my $output = join " and ", @outputs; + + # get file output in string format + my $file_string; + if ( $params{'format'} eq 'net' ) + { # write NET format + $file_string = $model->writeBNGL( \%params ); + } + elsif ( $params{'format'} eq 'bngl' ) + { # write BNGL format + $file_string = $model->writeBNGL( \%params ); + } + elsif ( $params{'format'} eq 'xml' ) + { # write XML format + $file_string = $model->toXML( \%params ); + } + + # write the string to file + my $FH; + open($FH, '>', $file) or return "Couldn't write to $file: $!\n"; + print $FH $file_string; + close $FH; + + # all done + print sprintf( "Wrote %s in %s format to %s.\n", $output, $params{'format'}, $file); + return undef; +} + + +# Write Model to a BNGL formatted string. +# This method returns a string and does NOT write to file. +# (also writes reaction network, if it exists) +sub writeBNGL +{ + use strict; + use warnings; + + my $model = shift @_; + my $user_params = @_ ? shift @_ : {}; + + # Default parameters required by this method. + # NOTE: since this method is not a user action, we don't need to check parameters. + # Instead, we assume the programmers call this method with valid options. + my %params = ( + 'convert_intensive_to_extensive_units' => 1, + 'evaluate_expressions' => 0, + 'format' => 'net', + 'include_model' => 1, + 'include_network' => 1, + 'pretty_formatting' => 1, + 'TextReaction' => 0, + 'TextSpecies' => 1, + ); + + # get any user parameters + while ( my ($key,$val) = each %$user_params ) + { $params{$key} = $val; } + + return '' if $NO_EXEC; + + + # !!! Begin writing file !!! + my $out = ''; + + # Header + my $version = BNGversion(); + my $codename = BNGcodename(); + if ($codename) + { $codename = '-' . $codename; } + $out .= "# Created by BioNetGen ${version}${codename}\n"; + + # Version requirements + unless ( $model->Version eq '' ) + { $out .= sprintf "version(\"%s\")\n", $model->Version; } + + # Options + while ( my ($opt,$val) = each %{$model->Options} ) + { + next if ( $opt eq 'prefix' ); # don't write prefix + next if ( $opt eq 'suffix' ); # don't write suffix + $out .= "setOption(\"$opt\",\"$val\")\n"; + } + + # Units + unless ($model->SubstanceUnits eq '') + { $out .= sprintf "substanceUnits(\"%s\")\n", $model->SubstanceUnits; } + + # Begin Model (BNGL only) + $out .= "\nbegin model\n" if ( $params{'format'} eq 'bngl' and $params{'pretty_formatting'} ); + + # Parameters + $out .= $model->ParamList->writeBNGL( \%params ); + + # Model blocks + if ( $params{'include_model'} ) + { + # Compartments + if ( defined $model->CompartmentList and @{$model->CompartmentList->Array} ) + { $out .= $model->CompartmentList->toString( $model->ParamList ); } + + # MoleculeTypes + if ( $model->MoleculeTypesList->StrictTyping ) + { $out .= $model->MoleculeTypesList->writeBNGL( \%params ); } + + # Observables + if ( @{$model->Observables} ) + { + # find max length of observable name + my $max_length = 0; + foreach my $obs ( @{$model->Observables} ) + { + $max_length = ( length $obs->Name > $max_length ) ? length $obs->Name : $max_length; + } + + $out .= "begin observables\n"; + my $io = 1; + foreach my $obs ( @{$model->Observables} ) + { + if ( $params{'pretty_formatting'} ) + { # no observable index + $out .= sprintf " %s\n", $obs->toString($max_length); + } + else + { # include index + $out .= sprintf "%5d %s\n", $io, $obs->toString(); + } + ++$io; + } + $out .= "end observables\n"; + } + + # Energy Patterns + if ( @{$model->EnergyPatterns} ) + { + $out .= "begin energy patterns\n"; + my $io = 1; + foreach my $epatt ( @{ $model->EnergyPatterns } ) + { + if ( $params{'pretty_formatting'} ) + { # no energy pattern index + $out .= sprintf " %s\n", $epatt->toString($model->ParamList); + } + else + { # include index + $out .= sprintf "%5d %s\n", $io, $epatt->toString($model->ParamList); + } + + ++$io; + }; + $out .= "end energy patterns\n"; + } + } + + # Functions + $out .= $model->ParamList->writeFunctions( \%params ); + + # Species + $out .= $model->SpeciesList->writeBNGL( $model->Concentrations, $model->ParamList, \%params ); + + + # Model Blocks + if ( $params{include_model} ) + { + # Reaction rules + $out .= "begin reaction rules\n"; + { + my $irxn = 1; + foreach my $rset ( @{$model->RxnRules} ) + { + my $rreverse = ( @$rset > 1 ) ? $rset->[1] : undef; + + # write BNGL rule + $out .= sprintf " %s\n", $rset->[0]->toString($rreverse); + + # write actions + if ( $params{'pretty_formatting'} ) + { # pretty, don't write actions + # do nothing! + } + else + { # write actions + $out .= $rset->[0]->listActions(); + if ( defined $rreverse ) + { + $out .= " # Reverse\n"; + $out .= $rset->[1]->listActions(); + } + } + ++$irxn; + } + } + $out .= "end reaction rules\n"; + } + + # Network blocks + if ( $params{'include_network'} ) + { + # Reactions + if ( $params{'TextReaction'} ) + { print "Writing full species names in reactions.\n"; } + $out .= $model->RxnList->writeBNGL( \%params, $model->ParamList ); + + # Groups + if ( @{$model->Observables} ) + { + $out .= "begin groups\n"; + my $io = 1; + foreach my $obs ( @{$model->Observables} ) + { + $out .= sprintf "%5d %s\n", $io, $obs->toGroupString( $model->SpeciesList ); + ++$io; + } + $out .= "end groups\n"; + } + } + + # End Model (BNGL only) + $out .= "end model\n" if ( $params{'format'} eq 'bngl' and $params{'pretty_formatting'} ); + + return $out; +} + + + +### +### +### + + + +# Syntax +# setOption(name,value,name,value,...) Set option value pairs +# First call will cause initialization with default values. +sub setOption +{ + my $model = shift @_; + my $err = ''; + + # Process options + while (@_) + { + my $arg = shift @_; + unless (@_) { return "No value specified for option $arg"; } + my $val = shift @_; + + # TODO: print arg and val to user? + + if ( $arg eq "SpeciesLabel" ) + { + # SpeciesLabel method can only be changed prior to reading species. + # Otherwise, inconsistent behavior could arise from changing the + # labeling method. + if ( $model->SpeciesList->size() ) + { return "$arg option can only be changed prior to defining species."; } + $err = SpeciesGraph::setSpeciesLabel($val); + if ($err) { return $err; } + $model->Options->{$arg} = $val; + } + elsif ( $arg eq "energyBNG" ) + { # enable energy mode + send_warning("The energyBNG option is now deprecated (energy features available by default)."); + } + elsif ( $arg eq "NumberPerQuantityUnit" ) + { # set conversion from quantity units to pure numbers + # TODO: allow this to be a parameter? + $model->Options->{$arg} = $val; + } + elsif ( $arg eq "MoleculesObservables" ) + { # set molecules observables mode + unless ($val eq "CountUnique" or $val eq "CountAll") + { return "Invalid option for or $arg (valid options are 'CountUnique' and 'CountAll')"; } + $model->Options->{$arg} = $val; + } + elsif ( $arg eq "SpeciesObservables" ) + { # set species observables mode + unless ($val eq "CountUnique" or $val eq "CountAll") + { return "Invalid option for or $arg (valid options are 'CountUnique' and 'CountAll')"; } + $model->Options->{$arg} = $val; + } + elsif ($arg =~ /Units$/) + { + my %unithash; + $unithash{'unit'} = $val; + $unithash{'exponent'} = 1; + $unithash{'scale'} = 0; + $unithash{'multiplier'} = 1; + $model->Options->{$arg} = \%unithash; + #return "Unrecognized option $arg in setOption"; + } + else + { + $model->Options->{$arg} = $val; + } + } + + return ''; +} + + +sub substanceUnits +{ + my $model = shift @_; + my $units = shift @_; + + my $ucommand = ""; + if ( $units =~ /^conc/i ) { + $ucommand = "Concentration"; + } + elsif ( $units =~ /^num/i ) { + $ucommand = "Number"; + } + else { + return "Invalid argument to subtanceUnits $units: valid arguments are Number and Concentration"; + } + + print "SubstanceUnits set to $ucommand.\n"; + $model->SubstanceUnits($ucommand); + return ''; +} + + +sub setVolume +{ + my $model = shift @_; + my $compartment_name = shift @_; + my $value = shift @_; + + return $model->CompartmentList->setVolume( $compartment_name, $value ); +} + + + +### +### +### + + + +sub setParameter +{ + my $model = shift @_; + my $pname = shift @_; + my $value = shift @_; + + return '' if $NO_EXEC; + + my $plist = $model->ParamList; + my ($param, $err); + + # Error if parameter doesn't exist + ( $param, $err ) = $plist->lookup($pname); + if ($err) { return ($err) } + + # Read expression + my $expr = Expression->new(); + my $estring = "$pname=$value"; + if ( $err = $expr->readString( \$estring, $plist ) ) { return $err; } + + # Set flag to update netfile when it's used + $model->UpdateNet(1); + + printf "Set parameter %s to value %s\n", $pname, $expr->evaluate($plist); + return ''; +} + + +# Save the current parameter definitions. +# Optionally specify a label to associate with the saved parameters. +sub saveParameters +{ + my $model = shift @_; + my $label = @_ ? shift @_ : Cache::DEFAULT_LABEL; + + return '' if $NO_EXEC; + + # copy paramList (exclude non-constant types) + my $paramlist = $model->ParamList->copyConstant(); + + # put saved concentration into cache + $model->ParameterCache->cache($paramlist,$label); + # Send message to user + printf "Saved current parameters with label '%s'\n", $label; + return undef; +} + + +# Reset parameters to saved defintions. +# Optionally specify a label used to find the saved parameters +sub resetParameters +{ + my $model = shift @_; + my $label = @_ ? shift @_ : Cache::DEFAULT_LABEL; + + return '' if $NO_EXEC; + + # get a COPY so that subsequent 'setParameter' calls don't modify the saved list + my $saved_paramlist = $model->ParameterCache->browse($label)->copyConstant(); + + unless (defined $saved_paramlist) + { return "resetParameters(): cannot find saved parameters"; } + + unless (ref $saved_paramlist eq 'ParamList') + { return "resetParameters(): problem retrieving saved parameters"; } + + # copy saved parameters into main ParamList + my $err; + foreach my $param ( @{$saved_paramlist->Array} ) + { + $err = $model->ParamList->add( $param ); + if ($err) { return "resetParameters(): problem resetting parameters ($err)"; } + } + + # Set flag to update netfile when it's used + $model->UpdateNet(1); + + # Send message to user + printf "Reloaded parameters saved with label '%s'\n", $label; + # all done + return undef; +} + + + +### +### +### + + + +# Set the concentration of a species to specified value. +# Value may be a number or a parameter. +sub setConcentration +{ + my $model = shift @_; + my $sname = shift @_; + my $value = shift @_; + + return '' if $NO_EXEC; + + my $plist = $model->ParamList; + my $err; + + # SpeciesGraph specified by $sname + my $sg = SpeciesGraph->new; + $err = $sg->readString( \$sname, $model->CompartmentList, 1, '', $model->MoleculeTypesList ); + if ($err) { return $err; } + + # Should check that this SG specifies a complete species, otherwise + # may match a number of species. + + # Find matching species + my $spec; + unless ( $spec = $model->SpeciesList->lookup($sg) ) + { + $err = sprintf "Species %s not found in SpeciesList", $sg->toString(); + return $err; + } + + # Read expression + my $expr = Expression->new(); + my $estring = $value; + if ( my $err = $expr->readString( \$estring, $plist ) ){ + return '', $err; + } + + # Evaluate observable and function names to values and reset + # the expression. Don't do this for parameters so that parameter + # scans can be run. + my $estring2 = $value; + my $variables = $expr->getVariables($plist); + foreach my $var ($variables->{'Observable'}){ # Observables + foreach my $name (keys %{$var}){ + my $val = $plist->evaluate($name); + $estring2 =~ (s/$name/$val/g); + } + } + foreach my $var ($variables->{'Function'}){ # Functions + foreach my $name (keys %{$var}){ + my $val = $plist->evaluate($name); + $estring2 =~ (s/$name(\(\))?/$val/g); + } + } + if ( my $err = $expr->readString( \$estring2, $plist ) ){ + return '', $err; + } + + # Either evaluate expression or create a new one with prefix 'NewConc' + my $conc; # = $expr->evaluate($plist); + if ( $expr->Type eq 'NUM' ){ + $conc = $expr->evaluate(); + } + else{ + $conc = $expr->getName( $plist, 'NewConc' ); + } + + # load Concentration array (if not already done) + $model->SpeciesList->checkOrInitConcentrations( $model->Concentrations ); + + # set concentration + $model->Concentrations->[$spec->Index - 1] = $conc; + + # Set flag to update netfile when it's used + $model->UpdateNet(1); + + printf "Set concentration of species %s to value %s\n", $spec->SpeciesGraph->StringExact, + ($expr->Type eq 'NUM' ? $conc : $expr->toString()); + return undef; +} + + +# Add concentration to a species. +# Value may be a number or a parameter. +sub addConcentration +{ + my $model = shift @_; + my $sname = shift @_; + my $value = shift @_; + + return '' if $NO_EXEC; + + my $plist = $model->ParamList; + my $err; + + # SpeciesGraph specified by $sname + my $sg = SpeciesGraph->new; + $err = $sg->readString( \$sname, $model->CompartmentList, 1, '', $model->MoleculeTypesList ); + if ($err) { return $err; } + + # Should check that this SG specifies a complete species, otherwise + # may match a number of species. + + # Find matching species + my $spec; + unless ( $spec = $model->SpeciesList->lookup($sg) ) + { + $err = sprintf "Species %s not found in SpeciesList", $sg->toString(); + return $err; + } + + # Read expression + my $expr = Expression->new(); + my $estring = $value; + if ( my $err = $expr->readString( \$estring, $plist ) ) + { + return ( '', $err ); + } + my $add_conc = $expr->evaluate($plist); + + # load Concentration array (if not already done) + $model->SpeciesList->checkOrInitConcentrations( $model->Concentrations ); + + # Add original concentration + my $orig_conc = $model->Concentrations->[$spec->Index - 1]; + unless ( isReal($orig_conc) ) + { # evaluate parameter + $orig_conc = $plist->evaluate($spec->Concentration); + } + my $conc = $add_conc + $orig_conc; + + # set new concentration + $model->Concentrations->[$spec->Index - 1] = $conc; + + # Set flag to update netfile when it's used + $model->UpdateNet(1); + + printf "Add %s counts (or concentration units) to species %s for total of %s\n", + $add_conc, $spec->SpeciesGraph->StringExact, $conc; + return undef; +} + + +# Save the current species concentrations. +# Optionally specify a label to associate with the saved state. +sub saveConcentrations +{ + my $model = shift @_; + my $label = @_ ? shift @_ : Cache::DEFAULT_LABEL; + + return '' if $NO_EXEC; + + # create new concentration array + my $conc = []; + if (@{$model->Concentrations}) + { # copy concentration from primary concentration array + @$conc = @{$model->Concentrations}; + } + else + { # if that's not defined, copy directly from SpeciesList + @$conc = map {$_->Concentration} @{$model->SpeciesList->Array}; + } + # put saved concentration into cache + $model->ConcentrationCache->cache($conc,$label); + print "Saved current species concentrations with label \"$label\"\n"; + return undef; +} + + +# Reset species concentrations to saved values. +# Optionally specify a label used to find the saved concentrations +sub resetConcentrations +{ + my $model = shift @_; + my $label = @_ ? shift @_ : Cache::DEFAULT_LABEL; + + return '' if $NO_EXEC; + + # lookup up concentrations in the cashe + my $saved_conc = $model->ConcentrationCache->browse($label); + + my $conc; + if ( (defined $saved_conc) and (ref $saved_conc eq 'ARRAY') ) + { # get a copy of the values (don't want to mess with originals) + @$conc = @$saved_conc; + } + elsif ( !(defined $saved_conc) ) + { # didn't find anything in the cache ... + if ( $label eq Cache::DEFAULT_LABEL ) + { # if we were looking for default values, get them directly from the species objects ... + @$conc = map {$_->Concentration} @{$model->SpeciesList->Array}; + } + else + { # otherwise return an error + return "resetConcentrations(): cannot find saved concentrations with label \"$label\""; + } + } + else + { # cache returned unexpected reference type + return "resetConcentrations(): some problem retrieving saved concentrations"; + } + + if ( @$conc > @{$model->SpeciesList->Array} ) + { # this case is not well-defined + return "resetConcentrations(): length of concentration vector is larger than the number of species"; + } + elsif ( @$conc < @{$model->SpeciesList->Array} ) + { # pad with zeros + my $n_zeros = @{$model->SpeciesList->Array} - @$conc; + push @$conc, (0) x $n_zeros; + } + + # finally, set concentrations to the saved values + $model->Concentrations($conc); + # Set flag to update netfile when it's used + $model->UpdateNet(1); + # all done + print "Reset species concentrations to \"$label\" saved values.\n"; + return undef; +} + + + +### +### +### + + + +sub setModelName +{ + my $model = shift @_; + my $name = shift @_; + + $model->Name($name); + return ''; +} + + +### +### +### + + + +# Function to require the version conform to specified requirement +# Syntax: version(string); +# string = major[.minor][.dist][+-][codename] +# +# major, minor, and dist. indicate the major, minor, and distribution number +# respectively against which the BioNetGen version numbers will be compared. +# + indicates version should be the specified version or later (default) +# - indicates version should be the specified version or earlier +sub version +{ + my $model = shift @_; + my $vstring = shift @_; + + return '' if $NO_EXEC; + + if (@_) + { # complain about too many arguments + return "Version called with too many arguments."; + } + + # extract version and codename + my ($version, $relation, $codename) = ( $vstring =~ /^(\d+\.\d+\.\d+)([+-]?)\s*(\w*)/ ); + + unless ( defined $version ) + { # complain that version is invalid + return "version argument '$vstring' has invalid format (make sure argument is enclosed in double quotes \"\")."; + } + + if ( $relation eq "" ) + { # default relation is "+" + $relation = "+"; + } + + my $bng_version = BNGversion(); + if ( $bng_version eq 'UNKNOWN' ) + { # complain that BNG version is unknown + return "BNG version is UNKNOWN!"; + } + + # compare versions (returns -1 if version < bng_version) + my $comp = compareVersions($version,$bng_version); + + # is active BNG version suitable? + if ( $relation eq '+' and $comp == 1 ) + { # BNG version is less than minimum required! + return "Requested BioNetGen version $version or greater. Active version is $bng_version."; + } + elsif ( $relation eq '-' and $comp == -1 ) + { # BNG version is greater than maximum allowed! + return "Requested BioNetGen version $version or lesser. Active version is $bng_version."; + } + + # check codename + unless ($codename eq "") + { + my $bng_codename = BNGcodename(); + unless ( $codename eq $bng_codename ) + { + return "Requested BioNetGen codename '${codename}'. Active codename is '${bng_codename}'."; + } + } + + # Set version requirement + $model->Version( $vstring ); + + # everything is good + return undef; +} + +sub codename +{ + my $model = shift @_; + my $codename = shift @_; + + return '' if $NO_EXEC; + + if (@_) + { # complain about too many arguments + return "Codename called with too many arguments."; + } + + unless ( $codename ) + { # complaiin about empty codename + return "codename argument is empty."; + } + + # get BNG codename + my $bng_codename = BNGcodename(); + if ( $bng_codename eq 'UNKNOWN' ) + { # complain that BNG codename is unknown + return "BNG version is UNKNOWN!"; + } + + # compare codename + unless ($codename eq $bng_codename) + { # BNG codename is not correct + return "Requested BioNetGen codename $codename. Active version is $bng_codename."; + } + + # Add current version requirement to the model + push @{$model->Codename}, $codename; + + # everything is good + return undef; +} + + +### +### +### + + + +sub quit +{ + # quick exit. no cleanup. no error messages + # This is useful when the user desires to exit before + # performing a set of actions and it would be tedious to + # comment out all those actions. + print "quitting BioNetGen!\n"; + exit(0); +} + + + +### +### +### + + + +# Add equilibrate option, which uses additional parameters +# t_equil and spec_nonequil. If spec_nonequil is set, these +# species are not used in equilibration of the network and are only +# added after equilibration is performed. Network generation should +# re-commence after equilibration is performed if spec_nonequil has +# been set. + +sub generate_network +{ + my $model = shift @_; + my $user_params = @_ ? shift @_ : {}; + + printf "ACTION: generate_network( %s )\n", $model->Name; + + # default params + my %params = ( + 'continue' => 1, + 'max_iter' => 100, + 'max_agg' => 1e9, + 'max_stoich' => {}, + 'check_iso' => 1, + 'prefix' => $model->getOutputPrefix(), + 'suffix' => undef, + 'overwrite' => 0, + 'print_iter' => 0, + 'TextSpecies' => 1, + 'TextReaction' => 0, + 'verbose' => 0, + 'write' => 1 + ); + + # overwrite default params with user params + foreach my $key (keys %$user_params) + { + my $val = $user_params->{$key}; + unless ( exists $params{$key} ) + { return "Unrecognized parameter $key in generate_network"; } + + $params{$key} = $val; + } + + return '' if $NO_EXEC; + + # Output prefix + if (defined $user_params->{prefix}){ + $params{prefix} = $model->getOutputPrefix($user_params->{prefix}); + } + + # add optional suffix to output prefix + if ( $params{suffix} ) + { $params{prefix} .= "_" . $params{suffix}; } + + # default params for calling writeNetwork + # (only need to change if we want non-default) + my $params_writeNetwork = { + 'include_model' => 0, + 'overwrite' => 1, + 'prefix' => $params{prefix}, + 'TextSpecies' => $params{TextSpecies}, + 'TextReaction' => $params{TextReaction} + }; + + # default params for calling expand_rule + my $params_expand_rule = { + 'check_iso' => $params{check_iso}, + 'max_agg' => $params{max_agg}, + 'max_stoich' => $params{max_stoich}, + 'verbose' => $params{verbose}, + }; + + # make sure 'max_stoich' molecules are valid names + foreach my $mol ( keys %{$params{'max_stoich'}} ){ + if ( not $mol =~ /^[A-Za-z_]\w*$/ ){ + return "Error in max_stoich: '$mol' is not a valid molecule name."; + } + } + + # check verbose option + my $verbose = $params{verbose}; + + # Check if existing net file has been created since last modification time of .bngl file + my $prefix = $params{prefix}; + if ( -e "$prefix.net" and -e "$prefix.bngl" ) + { + if ($params{overwrite}) + { + send_warning("Removing old network file $prefix.net."); + unlink "$prefix.net"; + } + elsif ( -M "$prefix.net" < -M "$prefix.bngl" ) + { + send_warning("$prefix.net is newer than $prefix.bngl so reading NET file."); + my $err = $model->readFile({file=>"${prefix}.net"}); + return $err; + } + else + { + return "Previously generated $prefix.net exists. Set overwrite=>1 option to overwrite."; + } + } + + if ( $model->SpeciesList->size() == 0 ) + { # warn user if the seed species list is empty. + send_warning("The seed species block is empty: reaction network will be empty " + ."unless zero-order synthesis rules are defined."); + } + + # nothing to do if no rules are defined + if ( @{$model->RxnRules} == 0 ) + { return "Nothing to do: no reaction rules defined."; } + + # if no reactions have been generated previously, then we have to initialize some things... + if ( $model->RxnList->size()==0 or $params{'continue'}==0 ) + { + # initialize rules + foreach my $rset ( @{$model->RxnRules} ) + { + foreach my $rr (@$rset) + { $rr->initializeRule(); } + } + # Initialize observables + foreach my $obs ( @{$model->Observables} ) + { + $obs->reset_weights( $model->SpeciesList->size() ); + $obs->update( $model->SpeciesList->Array ); + } + # Initialize energy patterns (for energy BNG only) + foreach my $epatt ( @{$model->EnergyPatterns} ) + { + $epatt->reset_weights($model->SpeciesList->size()); + $epatt->update($model->SpeciesList->Array); + } + # remember that we applied the observables + foreach my $sp ( @{$model->SpeciesList->Array} ) + { $sp->ObservablesApplied(1); } + } + else + { # friendly warning that we're continuing network generation + send_warning("Reaction list is already populated. Continuing network generation from where we last left off."); + } + + + my @rule_timing = (); + my @rule_nrxn = (); + + # update user with initial report + report_iter( 0, $model->SpeciesList->size(), $model->RxnList->size() ); + + # now perform network generation steps + foreach my $niter ( 1 .. $params{max_iter} ) + { + my $t_start_iter = cpu_time(0); + my @species = @{$model->SpeciesList->Array}; + + # Apply reaction rules + my $irule = 0; + my ($n_new, $t_off, $n_new_tot); + $n_new_tot = 0; + # NOTE: each element of @{$model->RxnRules} is an array of reactions. + # If a rule is unidirectional, then the array has a single element. + # If a rule is bidirectional, then the array has two elements (forward and reverse) + foreach my $rset ( @{$model->RxnRules} ) + { + if ($verbose) { printf "Rule %d:\n", $irule + 1; } + $n_new = 0; + $t_off = cpu_time(0); + my $dir = 0; + foreach my $rr (@$rset) + { + if ($verbose) + { + if ($dir == 0) { print " forward:\n"; } + else { print " reverse:\n"; } + } + # expand rule + my ($err, $nr) = $rr->expand_rule( \@species, $model, $params_expand_rule ); + if (defined $err) { return "Some problem expanding rule: $err"; } + $n_new += $nr; + ++$dir; + } + + my $time = cpu_time(0) - $t_off; + $rule_timing[$irule] += $time; + $rule_nrxn[$irule] += $n_new; + + if ($verbose) + { printf "Result: %5d new reactions %.2e CPU s\n", $n_new, $time; } + + $n_new_tot += $n_new; + ++$irule; + } + + # update RulesApplied for species processed in this interation + foreach my $spec (@species) + { $spec->RulesApplied($niter) unless ($spec->RulesApplied); } + + # report iteration to user + report_iter( $niter, $model->SpeciesList->size(), $model->RxnList->size(), $t_start_iter ); + + # Free memory associated with RxnList hash + $model->RxnList->resetHash(); + + # Stop iteration if no new species were generated + last if ( $model->SpeciesList->size() == scalar @species ); + + # Print network after current iteration to netfile + if ( $params{print_iter} and $params{write} ) + { + $params_writeNetwork->{prefix} = "${prefix}_${niter}"; + my $err = $model->writeNetwork($params_writeNetwork); + if ($err) { return $err; } + $params_writeNetwork->{prefix} = $prefix; + } + } + + + # Print rule timing information + printf "Cumulative CPU time for each rule\n"; + my $t_tot = 0; + my $n_tot = 0; + foreach my $irule ( 0 .. $#{$model->RxnRules} ) + { + my $eff = ( $rule_nrxn[$irule] ) ? $rule_timing[$irule] / $rule_nrxn[$irule] : 0.0; + printf "Rule %3d: %5d reactions %.2e CPU s %.2e CPU s/rxn\n", + $irule + 1, $rule_nrxn[$irule], $rule_timing[$irule], $eff; + $t_tot += $rule_timing[$irule]; + $n_tot += $rule_nrxn[$irule]; + } + my $eff = ($n_tot) ? $t_tot / $n_tot : 0.0; + printf "Total : %5d reactions %.2e CPU s %.2e CPU s/rxn\n", $n_tot, $t_tot, $eff; + + + # this is used in visualization, where a network is generated, but not written. + return if ($params{write}==0); + + # Print result to netfile + my $err = $model->writeNetwork($params_writeNetwork); + if ($err) { return $err; } + + # STATISTICAL FACTOR FOR REACTIONS- DEBUGGING + # OUTPUTS A FILE FOR EACH RULE + # SHOWING REACTION INSTANCES AND LUMPING + # DURING generate_network() + # NAME YOUR RULES FIRST! + # - JOHN SEKAR + + my $aut = $BNGModel::GLOBAL_MODEL->Params->{'write_autos'}; + if($aut==1) + { + foreach my $rxn(@{$model->RxnList->Array}) + { + my $str = $rxn->toString(1); + my %inst = %{$rxn->InstanceHash}; + my @k = keys %inst; + foreach my $rule(@k) + { + my $modelname = $BNGModel::GLOBAL_MODEL->Name; + my $rulename = $rule; + my $filename = join("_",($modelname,$rulename,"StatFactorCalculation")).".txt"; + open(my $autfile,">>",$filename) or die "Not found!"; + print $autfile "\nReaction\n".$str; + print $autfile "\nLumpFactor ".$inst{$rule}; + print $autfile "\nReactionStatFactor: RuleStatFactor*LumpFactor = ".$rxn->StatFactor."\n"; + close($autfile); + } + } + } + + return ''; + + + ### + ### + + + sub report_iter + { + my $niter = shift @_; + my $nspec = shift @_; + my $nrxn = shift @_; + my $t_start_iter = @_ ? shift @_ : undef; + + printf "Iteration %3d: %5d species %6d rxns", $niter, $nspec, $nrxn; + my $t_cpu = defined $t_start_iter ? cpu_time(0) - $t_start_iter : 0; + printf " %.2e CPU s", $t_cpu; + if ($HAVE_PS) { + my ( $rhead, $vhead, $rmem, $vmem ) = split ' ', `ps -o rss,vsz -p $$`; + printf " %.2e (%.2e) Mb real (virtual) memory.", + $t_cpu, $rmem / 1000, $vmem / 1000; + } + printf "\n"; + } + +} + + + +### +### +### + + + +# given a generic program name, returns the specific executable binary. +# returns empty string if binary can't be found +sub findExec +{ + use Config; + my $prog = shift @_; + + my $base = BNGpath( "bin", $prog ); + my $arch = $Config{myarchname}; + + # First look for generic binary in BNGpath + my $exec = $base; + if ($arch =~ /MSWin32/) { $exec .= ".exe"; } + if (-x $exec) { return $exec; } + + # Then look for OS-specific binary + $exec = "${base}_${arch}"; + if ($arch =~ /MSWin32/){ + my $bitness = $Config{longsize}*8; + $exec .= "-${bitness}bit" . ".exe"; + } + + if (-x $exec) { return $exec; } + else + { + print "findExec: $exec not found.\n"; + return ''; + } +} + + + +### +### +### + + + +# get output prefix = outputDir/modelName[_outputSuffix] +sub getOutputPrefix +{ + my $model = shift @_; + my $file_prefix = @_ ? shift @_ : $model->Name; + + my $is_absolute = File::Spec->file_name_is_absolute( $file_prefix ); + + if ( $model->Params->{suffix} ) + { $file_prefix .= '_' . $model->Params->{output_suffix}; } + + if ($is_absolute or $model->getOutputDir() eq "") + { + return $file_prefix; + } + else + { + return File::Spec->catfile( ($model->getOutputDir()), $file_prefix ); + } +} + +### +### + +# set the output directory, defaults to curdir if no argument is provided +sub setOutputDir +{ + my $model = shift @_; + my $dir = @_ ? shift @_ : undef; + + unless (defined $dir) + { # default to current directory + $dir = File::Spec->curdir(); + } + + # set output directory + $model->Params->{output_dir} = $dir; +} + +### +### + +# get the output directory +sub getOutputDir +{ + my $model = shift @_; + + unless ( defined $model->Params->{output_dir} ) + { # output directory not defined, set to default + $model->setOutputDir(); + } + + return $model->Params->{output_dir}; +} + + + +### +### +### + +1; + diff --git a/libvcell/vcell_install/bionetgen/Perl2/BNGOptions.pm b/libvcell/vcell_install/bionetgen/Perl2/BNGOptions.pm new file mode 100644 index 0000000..a6a033e --- /dev/null +++ b/libvcell/vcell_install/bionetgen/Perl2/BNGOptions.pm @@ -0,0 +1,66 @@ +package BNGOptions; +use strict; +use warnings; + +use Getopt::Long; +use Class::Struct; + +use BNGMessages qw(error warning message); + +struct BNGOptions => { + config=> '%', + nored=> '@', +}; + +#begin GetBNGOptions +sub GetBNGOptions +{ + my $self = shift; + $self->config->{macro}=''; #default value (false) - enable macromodel + $self->config->{silent}=''; #default value (false) - disable all (my only) messages + $self->config->{debug}= 1; #default value (false) - enable debug mode (debug output files) + $self->config->{bnglfile}=''; + $self->config->{filetype}=''; + $self->config->{prefix}=''; + $self->config->{ModelID}=''; + $self->config->{MAX_LEVEL}=5; #sets maximum level of allowed recursion + + + GetOptions ('silent' => \$self->config->{silent}, + 'macro' => \$self->config->{macro}, + 'debug' => \$self->config->{debug}, + 'nored=s'=> \@{$self->nored}); + + if ($self->config->{macro}) + { + $self->config->{ModelID}="BNGModels::MacroBNGModel"; + } + else + { + $self->config->{ModelID}="BNGModels::MicroBNGModel"; + } + + local $SIG{'__DIE__'} = sub { }; + local $SIG{'__WARN__'} = sub { }; + eval 'use '.$self->config->{ModelID}; + if ($@) { + @_ = split( "\n", $@ ); + $_ = join( "\n\t", @_ ); + error("Module $self->config->{ModelID} not loaded because: \n\t$_"); + } + else + { + eval 'use '.$self->config->{ModelID}; + } + + for my $file(@ARGV) + { + error("File $file does not have required .bngl extension.") unless ( ($file=~ /[.]bngl/)); + $self->config->{bnglfile}=$file; + $self->config->{prefix}=$file; + $self->config->{prefix}=~ s/[.]([^.]+)$//; + $self->config->{filetype}=uc("bngl"); + } +} +#end GetBNGOptions +1; diff --git a/libvcell/vcell_install/bionetgen/Perl2/BNGOutput.pm b/libvcell/vcell_install/bionetgen/Perl2/BNGOutput.pm new file mode 100644 index 0000000..bd5ec00 --- /dev/null +++ b/libvcell/vcell_install/bionetgen/Perl2/BNGOutput.pm @@ -0,0 +1,4770 @@ +package BNGModel; +# BNGOutput is part of the BNGModel package. This file contains Output commands +# including: writeXML, writeSBML, writeSSC, writeMfile, writeMexfile, ... + + +# pragmas +use strict; +use warnings; +use SBMLMultiAux; + +### +### +### + + +# write Model in XML format +# $err = $model->writeXML({opt=>val,..}) +sub writeXML +{ + use strict; + use warnings; + + my $model = shift @_; + my $user_params = @_ ? shift @_ : {}; + + my %params = ( + 'evaluate_expressions' => 1, + 'format' => 'xml', + 'include_model' => 1, + 'include_network' => 0, + 'overwrite' => 1, + ); + + # copy user_params into pass_params structures + while ( my ($key,$val) = each %$user_params ) + { $params{$key} = $val; } + + # writeFile will generate the output + return $model->writeFile( \%params ); +} + +# code for writeMDL starts here +sub writeMDL +{ + my $model = shift @_; + my $params = @_ ? shift @_ : {}; + + printf "ACTION: writeMDL( %s )\n", $model->Name; + + # a place to hold errors + my $err; + + # nothing to do if NO_EXEC is true + return '' if $BNGModel::NO_EXEC; + + # nothing to do if there are no reactions + if ( @{$model->RxnList->Array} == 0 ) + { + send_warning( "Reaction network not found. Attempting to generate network now."); + $model->generate_network({overwrite=>1}); + #return ( "writeMDL() has nothing to do: no reactions in current model.\n" + # ." Did you remember to call generate_network() before attempting to\n" + # ." write network output?"); + } + + # get reference to parameter list + my $plist = $model->ParamList; + + # get model name + my $model_name = $model->Name; + + # Build output file name + # ..use prefix if defined, otherwise use model name + my $prefix = defined $params->{prefix} ? $model->getOutputPrefix( $params->{prefix} ) : $model->getOutputPrefix(); + # ..add suffix, if any + my $suffix = ( defined $params->{suffix} ) ? $params->{suffix} : undef; + if ( $suffix ) + { $prefix .= "_${suffix}"; } + + # split prefix into volume, path and filebase + my ($vol, $path, $filebase) = File::Spec->splitpath($prefix); + + # define mdl-script file name + my $mdlscript_filedir = $path; #File::Spec->catpath($vol, $path); + my $mdlscript_filebase = "${filebase}"; + my $mdlscript_filename = "${mdlscript_filebase}.mdl"; + my $MDL; + + # create output directory where MDL files will be dumped + my $mdlscript_dumpdir = File::Spec->catdir($mdlscript_filedir,'MDL'); + unless(-e $mdlscript_dumpdir or mkdir $mdlscript_dumpdir) { + die "Unable to create $mdlscript_dumpdir\n"; + } + + # open file to write MDL script + my $mdlscript_path = File::Spec->catfile($mdlscript_dumpdir,$mdlscript_filename); + open( $MDL, '>', $mdlscript_path ) or die "Couldn't open $mdlscript_path: $!\n"; + + # get BNG version + my $version = BNGversion(); + use File::Basename; + my $bngpath = dirname(dirname(__FILE__)); + my $custom_geometry = 0; + my $bnglfiledir = dirname($model->Params->{'file'}); + + # look for custom geometry file in the directory where bngl file is located + my $custom_geometry_file = File::Spec->catfile($bnglfiledir,$mdlscript_filebase.".geometry.mdl"); + if ( -e $custom_geometry_file){ + $custom_geometry = 1; + } + # look for default geometry file in the directory where bngl file is located + my $default_geometry_file = File::Spec->catfile($bnglfiledir,"default.geometry.mdl"); + + # Read template geometry (Sphere with radius 1 micron) + my $iscomp = @{$model->CompartmentList->Array} ? 1 : 0; + my $text = ""; + my %object; + my %shape; + my %scale; + my @geometry; + + if (!$iscomp){ + open (READSHAPE, "<", $default_geometry_file) || die "Error loading default geometry: $default_geometry_file is missing or corrupted"; + @geometry = ; + close(READSHAPE); + + $text = join "", map {$_=~ /POLYGON_LIST/ ? $shape{"default"} = "default_".$_ : $_} @geometry; + $shape{"default"} =~ s/POLYGON_LIST//; $shape{"default"} =~ s/^\s+//; $shape{"default"} =~ s/\s+$//; + $object{"default"} = $shape{"default"}; + $shape{"default"} .= "[surface]"; + $scale{"default"} = (1000/4.19048)**(1/3); + } + + if ($iscomp && !$custom_geometry){ + open (READSHAPE, "<", $default_geometry_file) || die "Error loading default geometry: $default_geometry_file is missing or corrupted"; + @geometry = ; + close(READSHAPE); + + foreach my $comp (@{$model->CompartmentList->Array}){ + if (!$comp->Outside){ # If the outermost compartment is found, start from here. + $text .= $comp->getMDLgeometry($plist,\@geometry,\%object,\%shape,\%scale); + last; + } + } + } + + my %surf; #Each key of this hash represents a surface element in the geometry file. Corresponding value represents the name of the object/geometry to which the surface element belongs + my $overwrite_custom_geometry = 1; + if ($iscomp && $custom_geometry){ # This bloc will be excecuted if only a custom geometry is provided + open (READ_CUSTOM_GEOMETRY, "<", $custom_geometry_file) || die "Error loading custom geometry: $custom_geometry_file is missing or corrupted "; + my @custom_geometry = ; + close(READ_CUSTOM_GEOMETRY); + + my $lnum; + my $curly = 0; + my $brack = 0; + my $elemn = 0; + my $i = 0; + my $j = 0; + my $next_curly = 0; + my %obj; # A key of this hash repersents an object/geometry in the geometry file. Each value of this hash is a hash, whose keys are all surface element names belonging to the object + my $objname; + my %complist = map {$_->Name=>$_->Name} @{$model->CompartmentList->Array}; + + %shape = (); + %object = (); + %scale = (); + my %dummy_shape = (); + foreach my $line (@custom_geometry){ + if ($line =~ /obj_wall/){ + $overwrite_custom_geometry = 0; + } + $text .= $line; + ++$curly if ($line =~ /{/); + --$curly if ($line =~ /}/); + ++$lnum; + + if ($line =~/POLYGON_LIST/){ # A new geometric object found + $line =~ s/POLYGON_LIST//; + $line =~ s/^\s*//; # Remove preceding white spaces + $line =~ s/\s*$//; # Remove traling white spaces + die "Unknown compartment detected in custom geometry file $custom_geometry_file at line $lnum" unless exists $complist{$line}; + + $objname = $line; + $obj{$objname} = {}; + } + + $i = 1 if ($line =~ /ELEMENT_CONNECTIONS/); + if ($i){ + ++$brack if ($line =~ /{/); + --$brack if ($line =~ /}/); + ++$elemn if ($line =~ /\[/); + $i = 0 if (!$brack && $elemn > 0); + } + + $j=1 if ($line =~ /DEFINE_SURFACE_REGIONS/); + + if (($j == 1)&&($line =~/{/)){ + $j=0; + my $buf = $line; + $buf =~ s/\s*$//; + $buf =~ s/{//; + $buf .= " "; + $text .= $buf."obj_wall"; + $text .= "\n".$buf."{"; + $text .= "\n".$buf." ELEMENT_LIST = ["; + for (my $k=0; $k<$elemn; $k++){ + $text .= ($k < $elemn-1) ? $k.", " : $k."]\n"; + } + $text .= $buf."}\n"; + $elemn = 0; + + $shape{$objname} = $objname."[obj_wall]" unless exists $dummy_shape{$objname."[obj_wall]"}; + $dummy_shape{$objname."[obj_wall]"} = 1; + $object{$objname} = $objname; + $scale{$objname} = 1; + } + + if (($curly > 0)&&($line =~/ELEMENT_LIST/)){ + $line = $custom_geometry[$lnum-3]; + $line =~ s/^\s*//; + $line =~ s/\s*$//; + $surf{$line} = $objname; + $obj{$objname}->{$line} = 1; + $shape{$line} = $objname."[$line]" unless $line=~/obj_wall/; + $dummy_shape{$line} = 1; + } + } + + # Send error if any 2D compartment is not found as a surface region in the geometry file + foreach (@{$model->CompartmentList->Array}){ + if ($_->SpatialDimensions == 2){ + my $cname = $_->Name; + die "Compartment $cname is not specified as any surface region in the geometry file" unless (exists $surf{$cname}); + } + } + } + + if ($overwrite_custom_geometry){ + my $gfile = File::Spec->catfile($mdlscript_dumpdir,$mdlscript_filebase.".geometry.mdl"); + open (WRITEGEOMETRY, '>',$gfile) || die "Could not open $gfile: $!"; + print WRITEGEOMETRY $text; + close WRITEGEOMETRY; + print "Wrote MCell geometry file to $gfile.\n"; + } + + my $mdl; + my $indent = " "; + + # Define default iteration size and time step for mdl + $mdl = "ITERATIONS = 100000\n"."TIME_STEP = 5e-06\n"."VACANCY_SEARCH_DISTANCE = 100\n\n"; + $mdl .= "INCLUDE_FILE = \"${mdlscript_filebase}.geometry.mdl\"\n\n"; # Produced as a separate text file in the current directory + $mdl .= "DEFINE_SURFACE_CLASSES\n{\n".$indent."reflect {REFLECTIVE = ALL_MOLECULES}\n}\n\n"; + $mdl .= "MODIFY_SURFACE_REGIONS\n{\n"; + for my $key (keys %shape){ + $mdl .= $indent.$shape{$key}."\n"; + $mdl .= $indent."{\n"; + $mdl .= $indent.$indent."SURFACE_CLASS = reflect\n"; + $mdl .= $indent."}\n"; + } + $mdl .= "}\n\n"; + + # Define parameter block + my @py_param; + my $tpy_param = {}; + my @tpy_keys = ('name', 'value', 'unit', 'type'); + $mdl .= "\n/* Model Parameters */\n"; + $mdl .= $indent."Nav = 6.022e8 /* Avogadro number based on a volume size of 1 cubic um */\n" unless (exists $plist->{"Nav"}); + $tpy_param = {"name"=>"Nav", "value"=>"6.022e8", "unit"=>"", "type"=>"Avogadro number for 1 um^3"}; + #print "{"."'name':"."Nav,"."'value':"."6.022e8,"."'type':"."\"\","."'unit':"."Avogadro number for 1 um^3"."}"; + + push(@py_param,"{".join(",",map("\"$_\"".":\"".$tpy_param->{$_}."\"", @tpy_keys))."}"); + + my $rxn_layer_t = 0.01; + if ($iscomp){ + $mdl .= $indent."rxn_layer_t = $rxn_layer_t\n"; + $tpy_param={'name'=>"rxn_layer_t",'value'=>"0.01",'unit'=>"um",'type'=>""}; + push(@py_param,"{".join(",",map("\"$_\"".":\"".$tpy_param->{$_}."\"", @tpy_keys))."}"); + } + + # Scale parameters for MDL units + my %tcomp = (); + if ($iscomp){ + foreach (@{$model->CompartmentList->Array}){ + my $cname = $_->Size->toString(); + my $csize = $_->Size->evaluate($plist); + my $ssize = $_->getMDLSize($plist, $custom_geometry); # Volume of corresponding sphere + my $ssurf = ($_->SpatialDimensions == 2) ? ($custom_geometry? $ssize."/rxn_layer_t" : 4.836624601*($ssize)**(2/3)) : undef; # Surface area of corresponding sphere + # 2D compartments as the surface area of the enclosing sphere + $tcomp{$cname} = (defined $ssurf) ? $ssurf : $csize; + $mdl .= $indent.$cname." = ".$tcomp{$cname}.($ssurf ? " /*Surface area*/" : "")."\n"; + $tpy_param = {'name'=>$cname,'value'=>$tcomp{$cname},'unit'=>$ssurf ? "um^2": "um^3",'type'=>""}; + push(@py_param,"{".join(",",map("\"$_\"".":\"".$tpy_param->{$_}."\"", @tpy_keys))."}"); + } + } + + my %tparam = (); + my %rpy_param = (); + foreach my $rxn (@{$model->RxnList->Array}) + { + # Check if rate law type is elementary + if ($rxn->RateLaw->Type =~ "Ele"){ + my $rconst = $rxn->RateLaw->Constants->[0]; + # If rxn parameter unit has already been converted, no need for further calculation + if (exists $tparam{$rconst}) { next; } + # Find rate const value + my $rconst_val = $plist->evaluate($rconst); + # Store in new hash without converting, i.e., assuming reaction is unimolecular + $tparam{$rconst} = $rconst_val; + $tpy_param->{'name'} = $rconst; + $tpy_param->{'type'} = "Unimolecular reaction"; + $tpy_param->{'unit'} = "/s"; + # If reaction is bimolecular, overwrite hash value with the converted parameter value + if (@{$rxn->Reactants}==2){ + $tpy_param->{'type'} = "Bimolecular reaction"; + $tpy_param->{'unit'} = "/M.s"; + # Assume non-compartmental model. Apply default scaling in unit conversion (default volume 10^3 cubic micron) + my $scale = "1000*Nav"; + $tparam{$rconst} = $rconst_val."*".$scale; + # If model is compartmental, re-calculate the conversion + if ($iscomp){ + # Volume and dimension for compartment of the first reactant species + my ($vol1, $dim1, $ssize1) = ($_= $rxn->Reactants->[0]->SpeciesGraph->Compartment)? ($_->Size->toString(), $_->SpatialDimensions, $_->getMDLSize($plist, $custom_geometry)):(undef, undef, undef); + # Volume and dimension for compartment of the second reactant species + my ($vol2, $dim2, $ssize2) = ($_= $rxn->Reactants->[1]->SpeciesGraph->Compartment)? ($_->Size->toString(), $_->SpatialDimensions, $_->getMDLSize($plist, $custom_geometry)):(undef, undef, undef); + + if ((defined $dim1) && (defined $dim2)){ + my $sarea = $custom_geometry ? $_->Size->toString() : 4.836624601*($ssize1)**(2/3); + #$scale = ($dim1 > $dim2)? $vol1."*Nav" : (($dim2 > $dim1)? $vol2."*Nav" : (($dim1==3)? $vol1."*Nav" : $sarea)) ; # Sphere surface area comes into play only if both compartments are 2D + $scale = ($dim1 == 3) ? "*Nav" : (($dim2 ==3) ? "*Nav" : "/rxn_layer_t"); + if (($dim1 ==3) || ($dim2==3)){ + $tpy_param->{'unit'} = "/M.s"; + } + else{ + $tpy_param->{'unit'} = "um^2/#.s"; + } + #$scale = ($dim1 == 3)? "" : (($dim2 ==3 )? "" : "") ; # Sphere surface area comes into play only if both compartments are 2D + # Overwrite previously stored hash value with the new calculation + $tparam{$rconst} = $rconst_val.$scale; + } + } + } + $tpy_param->{'value'} = $tparam{$rconst}; + $rpy_param{$rconst} = "{".join(",",map("\"$_\"".":\"".$tpy_param->{$_}."\"", @tpy_keys))."}"; + } + } + + # Copy into the new hash any parameter that has not yet been included + foreach (@{$plist->Array}){ + unless ($tparam{$_->Name}) {$tparam{$_->Name} = $_->evaluate([],$plist) if ($_->Type =~ /^Constant/)}; + } + + foreach (@{$plist->Array}){ + if ($rpy_param{$_->Name}){ + push(@py_param, $rpy_param{$_->Name}) if ($_->Type =~ /^Constant/) ; + } + } + + $mdl .= join "", map {(exists $tparam{$_->Name} && (!exists $tcomp{$_->Name}))? $indent.$_->Name." = ".$tparam{$_->Name}."\n":""} @{$plist->Array}; + + # Molecule Types + #$mdl .= "\n/* Molecule Types */\n".$model->MoleculeTypesList->writeMDL($indent); + + # Define species and diffusion constants + my @py_species; # For writing python file for cell blender + my @dpy_param; + $mdl .= "\n/* Diffusion bloc */\n".$model->SpeciesList->writeMDL($model, $indent,\@py_species, \@dpy_param); + + my @py_reactions; + # Define reactions + $mdl .= "\n/* Reactions bloc */\n".$model->RxnList->writeMDL($plist, $iscomp, \@py_reactions); + + my @SeedSpecies; + foreach my $spc (@{$model->SpeciesList->Array}){ + push (@SeedSpecies, $spc) unless (!$spc->Concentration); + } + + # To include seed species concentrations as parameters for the CellBlender python file. + my @conc_array = map($_->Concentration, @SeedSpecies); + foreach my $par (@{$plist->Array}){ + if ($par->Type =~ /^Constant/) { + if (grep $_ eq $par->Name, @conc_array){ + $tpy_param = {'name'=>$par->Name,'value'=>$par->evaluate(),'unit'=>"Number",'type'=>""}; + push(@py_param,"{".join(",",map("\"$_\"".":\"".$tpy_param->{$_}."\"", @tpy_keys))."}"); + } + } + } + push(@py_param, @dpy_param); + + my @py_SeedSpecies; + foreach (@SeedSpecies){ + my $tpytext = "{"; + my $comp; + my $dim = ( $comp = $_->SpeciesGraph->Compartment) ? $comp->SpatialDimensions : 3; + my $orient = ($dim == 2)? "'" : ","; + $tpytext .= "\"name\":".sprintf("\"Release_Site_s%d\",",$_->Index); + $tpytext .= "\"molecule\":".sprintf("\"s%d\",",$_->Index); + $tpytext .= "\"shape\":".sprintf("\"%s\",","OBJECT"); + $tpytext .= "\"orient\":".sprintf("\"%s\",",$orient); + $tpytext .= "\"quantity_type\":".sprintf("\"%s\",","DENSITY"); + my $factor; + if ( $comp = $_->SpeciesGraph->Compartment){ + $factor = ($dim == 2 )? "/vol_".$comp->Name : "/(Nav*vol_".$comp->Name.")"; + } + else{ + $factor = "/(Nav*1000)"; + } + $tpytext .= "\"quantity_expr\":".sprintf("\"%s%s\",",$_->Concentration,$factor); + push(@py_SeedSpecies, $tpytext); + } + + $mdl .= ($custom_geometry) ? "" : "\n\n/************ DEFAULT GEOMETRY LOADED **********/\n"; + $mdl .= "\n\nINSTANTIATE Scene OBJECT\n{\n"; + + if ($custom_geometry){ + foreach my $key (keys %object){ # Outermost compartment is defined in BNGL file as a 2D boundary + $mdl .= $indent.$object{$key}." OBJECT ".$object{$key}." { SCALE = [$scale{$key}, $scale{$key}, $scale{$key}] }\n"; + } + } + else{ + foreach my $key (keys %shape){ # 2D buondary of the outer-most compartment is not defined in BNGL file as an additional compartment + $mdl .= $indent.$object{$key}." OBJECT ".$object{$key}." { SCALE = [$scale{$key}, $scale{$key}, $scale{$key}] }\n"; + } + } + + my $i = 0; + foreach (@SeedSpecies){ + my $relsite = $custom_geometry ? $_->getMDLRelSite(\%surf,\%shape,$custom_geometry) : $_->getMDLRelSite(\%object,\%shape); + $mdl .= "\n".$indent."s".$_->Index."_rel RELEASE_SITE\n$indent"."{\n$indent SHAPE = $relsite"; + $mdl .= "\n$indent MOLECULE = s".($iscomp ? ($_->SpeciesGraph->Compartment->SpatialDimensions == 3 ? $_->Index : $_->Index."'") : $_->Index); + $mdl .= "\n$indent NUMBER_TO_RELEASE = ".$_->Concentration."\n$indent RELEASE_PROBABILITY = 1"."\n$indent"."}"; + my $pyrelsite = $relsite; + $pyrelsite =~ s/Scene.//g; + $pyrelsite =~ s/obj_wall/ALL/g; + $py_SeedSpecies[$i] .= "\"object_expr\":".sprintf("\"%s\"}",$pyrelsite); + $i++; + } + $mdl .= "\n}"; + + my $pytext="{\n"; + $i = 0; + + + #@py_param = map{sprintf("%d", ++$i).":".$_} @py_param; + + $pytext .= "\"par_list\":[\n".$indent; + $pytext .= join(",\n$indent",@py_param); + $pytext .= "],"; + + $pytext .= "\n\n\"mol_list\":[\n".$indent; + $pytext .= join(",\n$indent",@py_species); + $pytext .= "],"; + + $i = 0; + #@py_reactions = map{sprintf("%d", ++$i).":".$_} @py_reactions; + $pytext .= "\n\n\"rxn_list\":[\n".$indent; + $pytext .= join(",\n$indent",@py_reactions); + $pytext .= "],"; + + + $i = 0; + #@py_SeedSpecies = map{sprintf("%d", ++$i).":".$_} @py_SeedSpecies; + $pytext .= "\n\n\"rel_list\":[\n".$indent; + $pytext .= join(",\n$indent",@py_SeedSpecies); + $pytext .= "]\n}"; + + + #my $pyfile = File::Spec->catfile(,"net.py"); + my $pyfile = "${path}${filebase}.bngl.json"; + open (WRITEPYFILE, '>', $pyfile); + print WRITEPYFILE $pytext; + close(WRITEPYFILE); + print "Wrote CellBlender reaction network script to $pyfile.\n"; + $mdl .= "\n\n/* Observables bloc */\nREACTION_DATA_OUTPUT\n{"; + $mdl .= "\n$indent"."STEP = 1e-6\n"; + foreach my $obs (@{$model->Observables}) { $mdl .= $obs->writeMDL(); } + $mdl .= "\n}\n\n"; + + $mdl .= "VIZ_OUTPUT {\n"."$indent"."MODE = CELLBLENDER\n"."$indent"."FILENAME = \"./viz_data/$mdlscript_filebase\"\n"; + $mdl .= "$indent"."MOLECULES\n"."$indent"."{\n"."$indent"."$indent"."NAME_LIST {ALL_MOLECULES}\n"."$indent"."$indent"."ITERATION_NUMBERS {ALL_DATA @ [1, 100, [200 TO 100000 STEP 100]]}\n"; + $mdl .= "$indent"."}\n"."}"; + + print $MDL $mdl; + close($mdlscript_path); + print "Wrote MDL file to $mdlscript_path.\n"; + return (); +} +# code for writeMDL ends here + +# generate XML string representing the BNGL model +sub toXML +{ + my $model = shift @_; + my $user_params = @_ ? shift @_ : {}; + + # default parameters + my %params = ( + 'evaluate_expressions' => 1, + ); + + # add user parameters + while ( my ($key,$val) = each %$user_params ) + { $params{$key} = $val; } + + return '' if $BNGModel::NO_EXEC; + + # get BNG version + my $version = BNGversion(); + + # get mopdel name + my $model_name = $model->Name; + + # define size of indent + my $indent = " "; + + # are we evaluating expressions? + my $evaluate_expressions = $params{'evaluate_expressions'}; + + # Begin writing XML # + # HEADER + my $xml = "\n" + ."\n" + ."\n" + ." \n"; + + + # Parameters + $xml .= $indent . "\n"; + my $indent2 = " " . $indent; + my $plist = $model->ParamList; + foreach my $param ( @{$plist->Array} ) + { + my $value; + my $type; + my $expr; + my $do_print = 0; + if ( $param->Type =~ /^Constant/ ) + { + $value = ($evaluate_expressions) ? sprintf "%.8g", $param->evaluate([], $plist) : $param->toString($plist); + $value =~ s/(e[+-])0+(\d+)/$1$2/; # strip any leading zeros in exponent (improves cross-platform portability) + $type = ($evaluate_expressions) ? "Constant" : $param->Type; + $expr = $param->toString($plist); + $do_print = 1; + } + next unless $do_print; + $xml .= sprintf( "$indent2Name ); + $xml .= " type=\"$type\""; + $xml .= " value=\"$value\""; + $xml .= " expr=\"$expr\""; + $xml .= "/>\n"; + } + $xml .= $indent . "\n"; + + # Molecule Types + $xml .= $model->MoleculeTypesList->toXML($indent); + + # Compartments + $xml .= $model->CompartmentList->toXML($indent, $plist); + + # Species + if (@{$model->Concentrations}){ + $xml .= $model->SpeciesList->toXML($indent,$model->Concentrations); + } else { + $xml .= $model->SpeciesList->toXML($indent); + } + + # Reaction rules + my $string = $indent . "\n"; + $indent2 = " " . $indent; + my $rindex = 1; + foreach my $rset ( @{$model->RxnRules} ) + { + foreach my $rr ( @$rset ) + { + $string .= $rr->toXML( $indent2, $rindex, $plist ); + ++$rindex; + } + } + $string .= $indent . "\n"; + $xml .= $string; + + # Observables + $string = $indent . "\n"; + $indent2 = " " . $indent; + my $oindex = 1; + foreach my $obs ( @{$model->Observables} ) + { + $string .= $obs->toXML( $indent2, $oindex ); + ++$oindex; + } + $string .= $indent . "\n"; + $xml .= $string; + + # Functions + $xml .= $indent . "\n"; + $indent2 = " " . $indent; + foreach my $param ( @{$plist->Array} ) + { + next unless ( $param->Type eq "Function" ); + $xml .= $param->Ref->toXML( $plist, $indent2 ); + } + $xml .= $indent . "\n"; + + # Energy Patterns + if ( @{$model->EnergyPatterns} ) { + $xml .= $indent . "\n"; + $indent2 = " " . $indent; + my $epindex = 1; + foreach my $eps ( @{$model->EnergyPatterns} ) + { + $xml .= $eps->toXML( $plist, $indent2, $epindex ); + ++$epindex; + } + $xml .= $indent . "\n"; + } + + # Population Maps + if ( defined $model->PopulationList ) { + if ( @{$model->PopulationList->List} ) { + $xml .= $model->PopulationList->toXML( $model, $plist, $indent ); + } + } + + + # FOOTER + $xml .= " \n" + ."\n"; + + return $xml; +} + + + +### +### +### + +# generate SBML-Multi string representing the BNGL model +sub writeSBMLMulti +{ + + my $model = shift @_; + my $params = @_ ? shift @_ : {}; + my $indent = " "; + + #return '' if $BNGModel::NO_EXEC; + + # get parameter list + my $plist = $model->ParamList; + + # get model name + my $model_name = $model->Name; + + # Strip prefixed path + my $prefix = defined $params->{prefix} ? $model->getOutputPrefix( $params->{prefix} ) : $model->getOutputPrefix(); + my $suffix = ( defined $params->{suffix} ) ? $params->{suffix} : 'sbml'; +# unless ( $suffix eq '' ) +# { + $prefix .= "_${suffix}"; +# } + + # define file name + my $file = "${prefix}_sbmlmulti.xml"; + + # open file + + # get BNG version + my $version = BNGUtils::BNGversion(); + + + # 0. HEADER +# print $SBML <<"EOF"; +# +# +# +# +#EOF + my $xml = qq{ + + + +}; + # 0. units + if(defined $model->Options("units")){ + my $unitstr = ''; + foreach my $option (keys %{$model->Options}){ + if ($option=~ /Units$/){ + my $optionName = substr($option,0,-5); + my $hashref = \%{$model->Options}; + my $unit = $hashref->{$option}{"unit"}; + my $exponent = $hashref->{$option}{"exponent"}; + my $scale = $hashref->{$option}{"scale"}; + my $multiplier = $hashref->{$option}{"multiplier"}; + $unitstr .= qq{ + + + + +}; + } + } + + if (! $unitstr eq ''){ + $xml .= " \n"; + $xml .= $unitstr; + $xml .= " \n"; + } + } + + # 1. Compartments +# print $SBML <<"EOF"; +# +# +# +#EOF + + my %paramHash = (); + $xml .= $model->writeSBMLParameters(\%paramHash); + + + if ($model->CompartmentList->Used) { # @a is not empty... + $xml = $xml . " \n"; + foreach my $comp (@{$model->CompartmentList->Array}) + { + $xml = $xml . $comp->toXML(" ", $plist); + } + $xml = $xml . " \n"; + #printf $SBML "%s",$model->CompartmentList->toXML(" "); + } + else { # @a is empty + + $xml = $xml . qq{ + + + }; + } + + + # stores a hash indexed by quasy labels containing a (counter, speciesgraph, sbmlmulti type string) typle + my %speciesSet = (); + # store sbml multi species types in a hash indexed by the sbmlmulti string containing a (speciesTypeID, speciesgraph) tuple + my %speciesTypeSet = (); + # hash containing bng string to sbml multi id information + my %speciesIdHash; + # hash containing binding components in the model + my %bindingComponents; + # 1.5 Get total list of species patterns in the system + $model->extractAllSpeciesGraphs(\%speciesSet, \%speciesTypeSet); + $model->extractBindingComponents(\%speciesSet, \%bindingComponents); + + + $speciesIdHash{'BindingInformation'} = \%bindingComponents; + #1.7 calculate species type information and string ahead of time since we will reuse this information + #in species definition + my $sbmlTypeStr; + #iterate over the species by id + my %sbmlMultiSpeciesTypeInfo; + + foreach my $speciesStr (sort {$speciesTypeSet{$a}[0] <=> $speciesTypeSet{$b}[0]} keys %speciesTypeSet) + { + my $sid = $speciesTypeSet{$speciesStr}[0]; + my $sg = $speciesTypeSet{$speciesStr}[1]; + my %attributes = ('multi:name', $speciesStr); + + $sbmlTypeStr .= $sg->toSBMLMultiSpeciesType($model->MoleculeTypesList, $indent, 'multi:speciesType', $sid, \%attributes, \%sbmlMultiSpeciesTypeInfo, \%speciesIdHash); + } + + + + + + # 2. walk through the total model species llist and fill in information + $xml .= $indent . "\n"; + #iterate over the species by id + my %print_options = ( + "sbml_multi", "1", + ); + + my %speciesConcentrationHash; + + foreach my $spec (@{$model->SpeciesList->Array}) + { + my $sname; + my $sexact= $spec->SpeciesGraph->StringExact; + my $c = $spec->Concentration; + if(exists $paramHash{$c}){ + $c = $paramHash{$c}; + } + $speciesConcentrationHash{$sexact} = $c; + } + + foreach my $speciesStr (sort {$speciesSet{$a}[0] <=> $speciesSet{$b}[0]} keys %speciesSet) + { + my $index = $speciesSet{$speciesStr}[0]; + my $sg = $speciesSet{$speciesStr}[1]; + my $speciesType; + my $conc = "0"; + if (exists $speciesConcentrationHash{$speciesStr}){ + $conc = $speciesConcentrationHash{$speciesStr}; + } + if(exists($speciesIdHash{'SpeciesType'}{$sg->getMultiSpeciesTypeStr()})){ + $speciesType = $speciesIdHash{'SpeciesType'}{$sg->getMultiSpeciesTypeStr()}; + } + else{ + $speciesType = $speciesIdHash{'Molecules'}{@{$sg->Molecules}[0]->Name}; + } + my %attributes = (); + + # Attributes + # concentration + if (defined $model->Options->{"substanceUnits"}){ + $attributes{"initialAmount"} = $conc; + $attributes{"hasOnlySubstanceUnits"} ="true"; + } + else{ + $attributes{"initialConcentration"} = $conc; + $attributes{"hasOnlySubstanceUnits"} ="false"; + } + + $attributes{"multi:speciesType"} = $speciesType; + + $xml .= $sg->toSBMLMultiSpecies($model->MoleculeTypesList, " ".$indent, "species", "S".$index, \%attributes, \%speciesIdHash); + } + + $xml .= $indent."\n"; + + + # 4. Assignment rules (for observables and functions) + if ( @{$model->Observables} or $plist->countType('Function') ){ + $xml .= "\n"; + if ( @{$model->Observables} ){ + $xml .= " \n"; + foreach my $obs ( @{$model->Observables} ) + { + $xml .= sprintf(" \n", $obs->Name); + $xml .= " \n"; + + $xml .= " \n"; + $xml .= " \n"; + my $n_elt = $obs->sizeOfGroup(); + + if ($n_elt<=1) + { + $xml .= sprintf " 0 \n"; + } + + foreach my $patt (@{$obs->Patterns}){ + $patt->labelHNauty(); + $xml .= sprintf " S%d \n", @{$speciesSet{$patt->StringExact}}[0]; + + } + + if ($n_elt==0) + { + $xml .= " 0 \n"; + } + + $xml .= " \n"; + $xml .= " \n"; + + #my ( $ostring, $err ) = $obs->toMathMLString(); + #if ($err) { return $err; } + #foreach my $line ( split "\n", $ostring ) + #{ + # $xml .= " $line\n"; + #} + $xml .= " \n"; + } + } + if ($plist->countType('Function')){ + $xml .= " \n"; + foreach my $param ( @{$plist->Array} ) + { + next unless ( $param->Type eq 'Function'); + next if ( @{$param->Ref->Args} ); # Don't print local functions + $xml .= sprintf(" \n", $param->Name); + + $xml .= $param->toMathMLString( $plist, " " ); + $xml .= " \n"; + } + } + $xml .= " \n"; + } + + # Reaction rules + $xml .= $model->writeSBMLReactions(\%speciesIdHash); + + + $xml .= $indent . "\n"; + + # finally append species type information + # top level species type + $xml .= $sbmlTypeStr; + # and child nodes species types + foreach my $speciesStr (sort {$sbmlMultiSpeciesTypeInfo{$a}[0] cmp $sbmlMultiSpeciesTypeInfo{$b}[0]} keys %sbmlMultiSpeciesTypeInfo) + { + $xml .= " " . $indent . $sbmlMultiSpeciesTypeInfo{$speciesStr}[1]; + } + + + $xml .= $indent."\n"; + + + # FOOTER + $xml .= " \n" + ."\n"; + + + my $FH; + open($FH, '>', $file) or return "Couldn't write to $file: $!\n"; + print $FH $xml; + close $FH; + return; +} + + + + +### +### +### + + +# write reaction network to SBML Level 2 Version 3 format +sub writeSBML +{ + my $model = shift @_; + my $params = @_ ? shift @_ : {}; + + return '' if $BNGModel::NO_EXEC; + + # nothing to do unless a reactions are defined + unless ( defined $model->RxnList and @{$model->RxnList->Array} ) + { return "writeSBML(): No reactions in current model--nothing to do."; } + + # get parameter list + my $plist = $model->ParamList; + + # get model name + my $model_name = $model->Name; + + # Strip prefixed path + my $prefix = defined $params->{prefix} ? $model->getOutputPrefix( $params->{prefix} ) : $model->getOutputPrefix(); + my $suffix = ( defined $params->{suffix} ) ? $params->{suffix} : 'sbml'; +# unless ( $suffix eq '' ) +# { + $prefix .= "_${suffix}"; +# } + + # define file name + my $file = "${prefix}.xml"; + + # open file + my $SBML; + open( $SBML, '>', $file ) or die "Couldn't open $file: $!\n"; + + # get BNG version + my $version = BNGUtils::BNGversion(); + + + # 0. HEADER +# print $SBML <<"EOF"; +# +# +# +# +#EOF + print $SBML qq{ + + + +}; + + # 1. Compartments +# print $SBML <<"EOF"; +# +# +# +#EOF + + # Default units + print $SBML " \n"; + print $SBML " \n"; + print $SBML " \n"; + print $SBML " \n"; + print $SBML " \n"; + print $SBML " \n"; + print $SBML " \n"; + + + if ($model->CompartmentList->Used) { # @a is not empty... + print $SBML " \n"; + foreach my $comp (@{$model->CompartmentList->Array}) + { + print $SBML $comp->toXML(" ", $plist); + } + print $SBML " \n"; + #printf $SBML "%s",$model->CompartmentList->toXML(" "); + } else { # @a is empty + print $SBML qq{ + + +}; + } + + + # 2. Species + print $SBML " \n"; + my $use_array = @{$model->Concentrations} ? 1 : 0; + foreach my $spec ( @{$model->SpeciesList->Array} ) + { + my $conc; + if ($use_array) + { $conc = $model->Concentrations->[ $spec->Index - 1 ]; } + else + { $conc = $spec->Concentration; } + + # If concentration is a parameter name, then evaluate the parameter + unless ( BNGUtils::isReal($conc) ) + { $conc = $plist->evaluate($conc, []); } + + # NOTE: In SBML Level 2 Version 2, the InitialAssignment construct was introduced that + # "permits the calculation of the value of a constant or the initial value of a variable + # from the values of other quantities in a model" -- see + # [http://sbml.org/Software/libSBML/docs/java-api/org/sbml/libsbml/InitialAssignment.html]. + # We could use this in the next version of writeSBML() to allow for variable initial + # concentrations. --LAH + my $compartmentString; + if (defined($spec->SpeciesGraph->Compartment)){ + $compartmentString = $spec->SpeciesGraph->Compartment->Name; + } + else{ + $compartmentString = "cell"; + } + + printf $SBML " Index, $compartmentString, $conc; + + if ( $spec->SpeciesGraph->Fixed ) + { printf $SBML " boundaryCondition=\"true\""; } + + printf $SBML " name=\"%s\"", $spec->SpeciesGraph->StringExact; + print $SBML "/>\n"; + } + print $SBML " \n"; + + + # 3. Parameters + # A. Rate constants + print $SBML " \n"; + if ($plist->countType('Constant')){ + print $SBML " \n"; + foreach my $param ( @{$plist->Array} ) + { + next unless ( $param->Type eq 'Constant' ); + printf $SBML " \n", $param->Name, $param->evaluate([], $plist); + } + } + if ($plist->countType('ConstantExpression')){ + print $SBML " \n"; + foreach my $param ( @{$plist->Array} ) + { + next unless ( $param->Type eq 'ConstantExpression' ); + next if ( $param->Name =~ /^_InitialConc/ ); + printf $SBML " \n", $param->Name; + } + } + + # B. Observables + if ( @{$model->Observables} ) + { + print $SBML " \n"; + foreach my $obs ( @{$model->Observables} ) + { + printf $SBML " \n", $obs->Name; + } + } + + # C. Global functions + if ($plist->countType('Function')){ + print $SBML " \n"; + foreach my $param ( @{$plist->Array} ) + { + next unless ( $param->Type eq 'Function'); + next if ( @{$param->Ref->Args} ); # Don't print local functions + printf $SBML " \n", $param->Name; + } + } + + print $SBML " \n"; + + + # 3.5. Initial assignments (for dependent variables) + print $SBML " \n"; + print $SBML " \n"; + foreach my $spec ( @{$model->SpeciesList->Array} ) + { + # we want this for all species + + if (not BNGUtils::isReal($spec->Concentration)) { + printf $SBML " \n", $spec->Index; + if ($spec->Concentration =~ /^_InitialConc/) { + (my $param_lookup, my $err) = $plist->lookup($spec->Concentration); + if ( defined $param_lookup ) { + print $SBML $param_lookup->Expr->toMathMLString( $plist, " " ); + } else { + print $SBML " \n"; + printf $SBML " %s \n", $spec->Concentration; + print $SBML " \n"; + } + } else { + print $SBML " \n"; + printf $SBML " %s \n", $spec->Concentration; + print $SBML " \n"; + } + print $SBML " \n"; + } + } + # we need to not do this IF we are replicating work + # that's already done above. We'll test later + if ($plist->countType('ConstantExpression')){ + print $SBML " \n"; + foreach my $param ( @{$plist->Array} ) + { + next if ( $param->Name =~ /^_InitialConc/ ); + next unless ( $param->Type eq 'ConstantExpression'); + printf $SBML " \n", $param->Name; + printf $SBML $param->toMathMLString( $plist, " " ); + print $SBML " \n"; + } + } + print $SBML " \n"; + + + + # 4. Assignment rules (for observables and functions) + if ( @{$model->Observables} or $plist->countType('Function') ){ + print $SBML " \n"; + if ( @{$model->Observables} ){ + print $SBML " \n"; + foreach my $obs ( @{$model->Observables} ) + { + # printf $SBML " \n", "Group_" . $obs->Name; + printf $SBML " \n", $obs->Name; + my ( $ostring, $err ) = $obs->toMathMLString(); + if ($err) { return $err; } + foreach my $line ( split "\n", $ostring ) + { + print $SBML " $line\n"; + } + print $SBML " \n"; + } + } + if ($plist->countType('Function')){ + print $SBML " \n"; + foreach my $param ( @{$plist->Array} ) + { + next unless ( $param->Type eq 'Function'); + next if ( @{$param->Ref->Args} ); # Don't print local functions + printf $SBML " \n", $param->Name; + printf $SBML $param->toMathMLString( $plist, " " ); + print $SBML " \n"; + } + } + print $SBML " \n"; + } + + # 5. Reactions + print $SBML " \n"; + my $index = 0; + foreach my $rxn ( @{$model->RxnList->Array} ) + { + ++$index; + printf $SBML " \n", $index; + + #Get indices of reactants + my @rindices = (); + foreach my $spec ( @{$rxn->Reactants} ) + { + push @rindices, $spec->Index; + } + @rindices = sort { $a <=> $b } @rindices; + + #Get indices of products + my @pindices = (); + foreach my $spec ( @{$rxn->Products} ) + { + push @pindices, $spec->Index; + } + @pindices = sort { $a <=> $b } @pindices; + + if (scalar(@rindices) > 0){ + print $SBML " \n"; + foreach my $i (@rindices) + { + printf $SBML " \n", $i; + } + print $SBML " \n"; + } + + if (scalar(@pindices) > 0){ + print $SBML " \n"; + foreach my $i (@pindices) + { + printf $SBML " \n", $i; + } + print $SBML " \n"; + } + + print $SBML " \n"; + + # pulling the compartment name + my $comp_name = undef; + my $conv_expr = undef; + my $err = undef; + my $rstring = undef; + # We need to know where the reaction takes place if this is + # a compartmental model and pass it to toMathMLString to add + # the correct volume correction + ($conv_expr, $comp_name, $err) = $rxn->get_intensive_to_extensive_units_conversion($BNGModel::GLOBAL_MODEL); + + + # toMathMLString adds a volume correction to the rate law for + # SBML output if this is a compartmental model. For non-compartmental + # models, SBML has a single compartment of volume 1 so it doesn't + # change anything. + # + # Kinetic laws in SBML are always in units of items/time + # so a volume is needed to convert concentration to items. + # See section 4.13.6 in SBML level 2, version 5: + # http://sbml.org/Special/specifications/sbml-level-2/version-5/release-1/sbml-level-2-version-5-rel-1.pdf + # The default behavior of SBML tools seems to assume concentrations + # for the species and the volume that's used here is expected for + # kinetic laws. Without this correction, the dynamics of BNG and + # SBML tools (e.g. COPASI, libroadrunner) does not match. + ( $rstring, $err ) = $rxn->RateLaw->toMathMLString( \@rindices, \@pindices, $rxn->StatFactor, $comp_name ); + if ($err) { return $err; } + + foreach my $line ( split "\n", $rstring ) + { + print $SBML " $line\n"; + } + print $SBML " \n"; + + print $SBML " \n"; + } + print $SBML " \n"; + + + # 6. FOOTER +# print $SBML <<"EOF"; +# +# +#EOF + print $SBML qq{ + +}; + + close $SBML; + print "Wrote SBML to $file.\n"; + return; +} + + + +### +### +### + + + +sub writeSSC +{ + my $model = shift @_; + my $params = @_ ? shift @_ : {}; + return '' if $BNGModel::NO_EXEC; + + # get model name + my $model_name = $model->Name; + + my $prefix = defined $params->{prefix} ? $model->getOutputPrefix( $params->{prefix} ) : $model->getOutputPrefix(); + my $suffix = ( defined $params->{suffix} ) ? $params->{suffix} : undef; + if ( $suffix ) { + $prefix .= "_${suffix}"; + } + my $file = "${prefix}.rxn"; + open( SSCfile, ">$file" ) || die "Couldn't open $file: $!\n"; + my $version = BNGversion(); + print SSCfile + "--# SSC-file for model $model_name created by BioNetGen $version\n"; + print "Writing SSC translator .rxn file....."; + + #-- Compartment default for SSC ---- look more into it + printf SSCfile + "region World \n box width 1 height 1 depth 1\nsubvolume edge 1"; + + # --This part corresponds to seed species + print SSCfile "\n\n"; + print SSCfile "--# Initial molecules and their concentrations\n"; + my $sp_string = $model->SpeciesList->writeSSC( $model->Concentrations, + $model->ParamList ); + print SSCfile $sp_string; + + # --This part in SSC corrsponds to Observables + if ( @{$model->Observables }) + { + print SSCfile"\n\n--# reads observables"; + print SSCfile "\n"; + foreach my $obs ( @{$model->Observables} ) + { + my $ob_string = $obs->toStringSSC(); + if ( $ob_string =~ /\?/ ) + { + print STDOUT " \n WARNING: SSC does not implement ?. The observable has been commented. Please see .rxn file for more details \n"; + print STDOUT "\n See Observable\n", $obs->toString(); + $ob_string = "\n" . "--#" . "record " . $ob_string; + print SSCfile $ob_string; + } #putting this string as a comment and carrying on + else + { + print SSCfile "\nrecord ", $ob_string; + } + } + } + + # --Reaction rules + print SSCfile" \n\n--# reaction rules\n"; + foreach my $rset ( @{$model->RxnRules} ) + { + my $id = 0; + my $rreverse = ( $#$rset > 0 ) ? $rset->[1] : ""; + ( my $reac1, my $errorSSC ) = $rset->[0]->toStringSSC($rreverse); + if ( $errorSSC == 1 ) + { + print STDOUT "\nSee rule in .rxn \n", + $rset->[0]->toString($rreverse); + $reac1 = "--#" . $reac1; + } + print SSCfile $reac1; + print SSCfile "\n"; + if ($rreverse) + { + ( my $reac2, my $errorSSC ) = $rset->[1]->toStringSSC($rreverse); + if ( $errorSSC == 1 ) { $reac2 = "--#" . $reac2; } + print SSCfile $reac2; + print SSCfile "\n"; + } + } + print "\nWritten SSC file\n"; + return (); +} + + + +# This subroutine writes a file which contains the information corresponding to the parameter block in BNG +sub writeSSCcfg +{ + my $model = shift @_; + my $params = @_ ? shift @_ : {}; + return '' if $BNGModel::NO_EXEC; + + # get model name + my $model_name = $model->Name; + + # Strip prefixed path + my $prefix = defined $params->{prefix} ? $model->getOutputPrefix( $params->{prefix} ) : $model->getOutputPrefix(); + my $suffix = ( defined $params->{suffix} ) ? $params->{suffix} : ''; + if ( $suffix ne '' ) + { + $prefix .= "_${suffix}"; + } + + my $file = "${prefix}.cfg"; + my $version = BNGversion(); + + open( SSCcfgfile, ">$file" ) || die "Couldn't open $file: $!\n"; + print STDOUT "\n Writting SSC cfg file \n"; + print SSCcfgfile "# SSC cfg file for model $model_name created by BioNetGen $version\n"; + print SSCcfgfile $model->ParamList->writeSSCcfg(); + + return; +} + + + +### +### +### + + + +# Write model to a MATLAB M-file +sub writeMfile +{ + my $model = shift @_; + my $params = @_ ? shift @_ : {}; + + # a place to hold errors + my $err; + + # nothing to do if NO_EXEC is true + return '' if $BNGModel::NO_EXEC; + + # nothing to do if there are no reactions + if ( @{$model->RxnList->Array}==0 ) + { + return "writeMfile() has nothing to do: no reactions in current model. " + ."Did you remember to call generate_network() before attempting to " + ."write network output?"; + } + + # get reference to parameter list + my $plist = $model->ParamList; + + # get model name + my $model_name = $model->Name; + + # Build output file name + # ..use prefix if defined, otherwise use model name + my $prefix = defined $params->{prefix} ? $model->getOutputPrefix( $params->{prefix} ) : $model->getOutputPrefix(); + # ..add suffix, if any + my $suffix = ( defined $params->{suffix} ) ? $params->{suffix} : undef; + if ( $suffix ) + { $prefix .= "_${suffix}"; } + + # split prefix into volume, path and filebase + my ($vol, $path, $filebase) = File::Spec->splitpath($prefix); + + # define m-script file name + my $mscript_filebase = "${filebase}"; + my $mscript_filename = "${mscript_filebase}.m"; + my $mscript_path = File::Spec->catpath($vol,$path,$mscript_filename); + my $mscript_filebase_caps = uc $mscript_filebase; + + # configure options (see Matlab documentation of functions ODESET and ODE15S) + my $odeset_abstol = 1e-4; + if ( exists $params->{'atol'} ) + { $odeset_abstol = $params->{'atol'}; } + + my $odeset_reltol = 1e-8; + if ( exists $params->{'rtol'} ) + { $odeset_reltol = $params->{'rtol'}; } + + my $odeset_stats = 'off'; + if ( $params->{'stats'} ) + { $odeset_stats = 'on'; } +# if ( exists $params->{'stats'} ) +# { $odeset_stats = $params->{'stats'}; } + + my $odeset_bdf = 'off'; + if ( $params->{'bdf'} ) + { $odeset_bdf = 'on'; } +# if ( exists $params->{'bdf'} ) +# { $odeset_bdf = $params->{'bdf'}; } + + my $odeset_maxorder = 5; + if ( exists $params->{'maxOrder'} ) + { $odeset_maxorder = $params->{'maxOrder'}; } + + # time options for mscript + my $t_start = 0; + if ( exists $params->{'t_start'} ) + { $t_start = $params->{'t_start'}; } + + my $t_end = 10; + if ( exists $params->{'t_end'} ) + { $t_end = $params->{'t_end'}; } + + my $n_steps = 20; + if ( exists $params->{'n_steps'} ) + { $n_steps = $params->{'n_steps'}; } + + # configure time step dependent options + my $odeset_maxstep = undef; + if ( exists $params->{'max_step'} ) + { $odeset_maxstep = $params->{'max_step'}; } + + # construct ODESET function call + my $mscript_call_odeset; + if ( defined $odeset_maxstep ) + { + $mscript_call_odeset = "opts = odeset( 'RelTol', $odeset_reltol, ...\n" + ." 'AbsTol', $odeset_abstol, ...\n" + ." 'Stats', '$odeset_stats', ...\n" + ." 'BDF', '$odeset_bdf', ...\n" + ." 'MaxOrder', $odeset_maxorder, ...\n" + ." 'MaxStep', $odeset_maxstep );\n"; + } + else + { + $mscript_call_odeset = "opts = odeset( 'RelTol', $odeset_reltol, ...\n" + ." 'AbsTol', $odeset_abstol, ...\n" + ." 'Stats', '$odeset_stats', ...\n" + ." 'BDF', '$odeset_bdf', ...\n" + ." 'MaxOrder', $odeset_maxorder );\n"; + } + # strip any leading zeros in exponent (improves cross-platform portability) + $mscript_call_odeset =~ s/(e[+-])0+(\d+)/$1$2/g; + + # Index parameters associated with Constants, ConstantExpressions and Observables + ($err) = $plist->indexParams(); + if ($err) { return $err }; + + # and retrieve a string of expression definitions + my $n_parameters = $plist->countType( 'Constant' ); + my $n_expressions = $plist->countType( 'ConstantExpression' ) + $n_parameters; + (my $calc_expressions_string, $err) = $plist->getMatlabExpressionDefs(); + if ($err) { return $err }; + + # get list of parameter names and defintions for matlab + my $mscript_param_names; + my $mscript_param_values; + ($mscript_param_names, $mscript_param_values, $err) = $plist->getMatlabConstantNames(); + if ($err) { return $err }; + + # get number of species + my $n_species = scalar @{$model->SpeciesList->Array}; + + # retrieve a string of observable definitions + my $n_observables = scalar @{$model->Observables}; + my $calc_observables_string; + ($calc_observables_string, $err) = $plist->getMatlabObservableDefs(); + if ($err) { return $err }; + + # get list of observable names for matlab + my $mscript_observable_names; + ($mscript_observable_names, $err) = $plist->getMatlabObservableNames(); + if ($err) { return $err }; + + # Construct user-defined functions + my $user_fcn_declarations = ''; + my $user_fcn_definitions = ''; + foreach my $param ( @{ $model->ParamList->Array } ) + { + if ( $param->Type eq 'Function' ) + { + # get reference to the actual Function + my $fcn = $param->Ref; + + # don't write function if it depends on a local observable evaluation (this is useless + # since CVode can't do local evaluations) + next if ( $fcn->checkLocalDependency($plist) ); + + # get function definition + my $fcn_defn = $fcn->toMatlabString( $plist, {fcn_mode=>'define', indent=>''} ); + + # add definition to the user_fcn_definitions string + $user_fcn_definitions .= $fcn_defn . "\n"; + } + } + + # index reactions + ($err) = $model->RxnList->updateIndex( $plist ); + if ($err) { return $err }; + + # retrieve a string of reaction rate definitions + my $n_reactions = scalar @{$model->RxnList->Array}; + my $calc_ratelaws_string; + ($calc_ratelaws_string, $err) = $model->RxnList->getMatlabRateDefs( $plist ); + if ($err) { return $err }; + + + # get stoichiometry matrix (sparse encoding in a hashmap) + my $stoich_hash = {}; + ($err) = $model->RxnList->calcStoichMatrix( $stoich_hash ); + + # retrieve a string of species deriv definitions + my $calc_derivs_string; + ($calc_derivs_string, $err) = $model->SpeciesList->toMatlabString( $model->RxnList, $stoich_hash, $plist ); + if ($err) { return $err }; + + + # get list of species names and initial value expressions for matlab + my $mscript_species_names; + my $mscript_species_init; + ($mscript_species_names, $mscript_species_init, $err) = $model->SpeciesList->getMatlabSpeciesNames( $model ); + if ($err) { return $err }; + + + ## Set up MATLAB Plot + # fontsizes + my $title_fontsize = 14; + my $axislabel_fontsize = 12; + my $legend_fontsize = 10; + + # generate code snippets for plotting observables or species + my $mscript_plot_labels; + my $mscript_make_plot; + + # get ylabel (either Number of Concentration) + my $ylabel; + if ( $model->SubstanceUnits eq 'Number' ) + { $ylabel = 'number'; } + elsif ( $model->SubstanceUnits eq 'Concentration' ) + { $ylabel = 'concentration'; } + else + { $ylabel = 'number or concentration'; } + + + if ( @{$model->Observables} ) + { # plot observables + $mscript_plot_labels = " observable_labels = { $mscript_observable_names };\n"; + + $mscript_make_plot = " plot(timepoints,observables_out);\n" + ." title('${mscript_filebase} observables','fontSize',${title_fontsize},'Interpreter','none');\n" + ." axis([${t_start} timepoints(end) 0 inf]);\n" + ." legend(observable_labels,'fontSize',${legend_fontsize},'Interpreter','none');\n" + ." xlabel('time','fontSize',${axislabel_fontsize},'Interpreter','none');\n" + ." ylabel('${ylabel}','fontSize',${axislabel_fontsize},'Interpreter','none');\n"; + + } + else + { # plot species + $mscript_plot_labels = " species_labels = { $mscript_species_names };\n"; + + $mscript_make_plot = " plot(timepoints,species_out);\n" + ." title('${mscript_filebase} species','fontSize',${title_fontsize},'Interpreter','none');\n" + ." axis([${t_start} timepoints(end) 0 inf]);\n" + ." legend(species_labels,'fontSize',${legend_fontsize},'Interpreter','none');\n" + ." xlabel('time','fontSize',${axislabel_fontsize},'Interpreter','none');\n" + ." ylabel('${ylabel}','fontSize',${axislabel_fontsize},'Interpreter','none');\n"; + } + + + + # open Mexfile and begin printing... + open( Mscript, ">$mscript_path" ) || die "Couldn't open $mscript_path: $!\n"; + print Mscript <<"EOF"; +function [err, timepoints, species_out, observables_out] = ${mscript_filebase}( timepoints, species_init, parameters, suppress_plot ) +%${mscript_filebase_caps} Integrate reaction network and plot observables. +% Integrates the reaction network corresponding to the BioNetGen model +% '${model_name}' and then (optionally) plots the observable trajectories, +% or species trajectories if no observables are defined. Trajectories are +% generated using either default or user-defined parameters and initial +% species values. Integration is performed by the MATLAB stiff solver +% 'ode15s'. ${mscript_filebase_caps} returns an error value, a vector of timepoints, +% species trajectories, and observable trajectories. +% +% [err, timepoints, species_out, observables_out] +% = $mscript_filebase( timepoints, species_init, parameters, suppress_plot ) +% +% INPUTS: +% ------- +% species_init : row vector of $n_species initial species populations. +% timepoints : column vector of time points returned by integrator. +% parameters : row vector of $n_parameters model parameters. +% suppress_plot : 0 if a plot is desired (default), 1 if plot is suppressed. +% +% Note: to specify default value for an input argument, pass the empty array. +% +% OUTPUTS: +% -------- +% err : 0 if the integrator exits without error, non-zero otherwise. +% timepoints : a row vector of timepoints returned by the integrator. +% species_out : array of species population trajectories +% (columns correspond to species, rows correspond to time). +% observables_out : array of observable trajectories +% (columns correspond to observables, rows correspond to time). +% +% QUESTIONS about the BNG Mfile generator? Email justinshogg\@gmail.com + + + +%% Process input arguments + +% define any missing arguments +if ( nargin < 1 ) + timepoints = []; +end + +if ( nargin < 2 ) + species_init = []; +end + +if ( nargin < 3 ) + parameters = []; +end + +if ( nargin < 4 ) + suppress_plot = 0; +end + + +% initialize outputs (to avoid error msgs if script terminates early +err = 0; +species_out = []; +observables_out = []; + + +% setup default parameters, if necessary +if ( isempty(parameters) ) + parameters = [ $mscript_param_values ]; +end +% check that parameters has proper dimensions +if ( size(parameters,1) ~= 1 || size(parameters,2) ~= $n_parameters ) + fprintf( 1, 'Error: size of parameter argument is invalid! Correct size = [1 $n_parameters].\\n' ); + err = 1; + return; +end + +% setup default initial values, if necessary +if ( isempty(species_init) ) + species_init = initialize_species( parameters ); +end +% check that species_init has proper dimensions +if ( size(species_init,1) ~= 1 || size(species_init,2) ~= $n_species ) + fprintf( 1, 'Error: size of species_init argument is invalid! Correct size = [1 $n_species].\\n' ); + err = 1; + return; +end + +% setup default timepoints, if necessary +if ( isempty(timepoints) ) + timepoints = linspace($t_start,$t_end,$n_steps+1)'; +end +% check that timepoints has proper dimensions +if ( size(timepoints,1) < 2 || size(timepoints,2) ~= 1 ) + fprintf( 1, 'Error: size of timepoints argument is invalid! Correct size = [t 1], t>1.\\n' ); + err = 1; + return; +end + +% setup default suppress_plot, if necessary +if ( isempty(suppress_plot) ) + suppress_plot = 0; +end +% check that suppress_plot has proper dimensions +if ( size(suppress_plot,1) ~= 1 || size(suppress_plot,2) ~= 1 ) + fprintf( 1, 'Error: suppress_plots argument should be a scalar!\\n' ); + err = 1; + return; +end + +% define parameter labels (this is for the user's reference!) +param_labels = { $mscript_param_names }; + + + +%% Integrate Network Model + +% calculate expressions +[expressions] = calc_expressions( parameters ); + +% set ODE integrator options +$mscript_call_odeset + +% define derivative function +rhs_fcn = @(t,y)( calc_species_deriv( t, y, expressions ) ); + +% simulate model system (stiff integrator) +try + [~, species_out] = ode15s( rhs_fcn, timepoints, species_init', opts ); + if(length(timepoints) ~= size(species_out,1)) + exception = MException('ODE15sError:MissingOutput','Not all timepoints output\\n'); + throw(exception); + end +catch + err = 1; + fprintf( 1, 'Error: some problem encountered while integrating ODE network!\\n' ); + return; +end + +% calculate observables +observables_out = zeros( length(timepoints), $n_observables ); +for t = 1 : length(timepoints) + observables_out(t,:) = calc_observables( species_out(t,:), expressions ); +end + + +%% Plot Output, if desired + +if ( ~suppress_plot ) + + % define plot labels +$mscript_plot_labels + % construct figure +$mscript_make_plot +end + + +%~~~~~~~~~~~~~~~~~~~~~% +% END of main script! % +%~~~~~~~~~~~~~~~~~~~~~% + +% Define if function to allow nested if statements in user-defined functions +function [val] = if__fun (cond, valT, valF) +% IF__FUN Select between two possible return values depending on the boolean +% variable COND. + if (cond) + val = valT; + else + val = valF; + end +end + +% initialize species function +function [species_init] = initialize_species( params ) + + species_init = zeros(1,$n_species); +$mscript_species_init +end + + +% user-defined functions +$user_fcn_definitions + + +% Calculate expressions +function [ expressions ] = calc_expressions ( parameters ) + + expressions = zeros(1,$n_expressions); +$calc_expressions_string +end + + + +% Calculate observables +function [ observables ] = calc_observables ( species, expressions ) + + observables = zeros(1,$n_observables); +$calc_observables_string +end + + +% Calculate ratelaws +function [ ratelaws ] = calc_ratelaws ( species, expressions, observables ) + + ratelaws = zeros(1,$n_observables); +$calc_ratelaws_string +end + +% Calculate species derivatives +function [ Dspecies ] = calc_species_deriv ( time, species, expressions ) + + % initialize derivative vector + Dspecies = zeros($n_species,1); + + % update observables + [ observables ] = calc_observables( species, expressions ); + + % update ratelaws + [ ratelaws ] = calc_ratelaws( species, expressions, observables ); + + % calculate derivatives +$calc_derivs_string +end + + +end +EOF + + close(Mscript); + print "Wrote M-file script $mscript_path.\n"; + open( Mscript, "| perl -pi.bak -e 's/_rateLaw/rateLaw__/g' $mscript_path" ) || die "Couldn't open $mscript_path: $!\n"; + close(Mscript); + my $toRemove = $mscript_path . ".bak"; + unlink($toRemove); + return (); +} + + + +### +### +### + + + +sub writeMEXfile +{ + my $model = shift @_; + my $params = (@_) ? shift @_ : {}; + my $err = $model->writeMexfile( $params ); + return $err; +} + + +sub writeMexfile +{ + my $model = shift; + my $params = (@_) ? shift : {}; + + # a place to hold errors + my $err; + + # nothing to do if NO_EXEC is true + return '' if $BNGModel::NO_EXEC; + + # nothing to do if there are no reactions + if ( @{$model->RxnList->Array}==0 ) + { + return "writeMexfile() has nothing to do: no reactions in current model. " + ."Did you remember to call generate_network() before attempting to " + ."write network output?"; + } + + # get reference to parameter list + my $plist = $model->ParamList; + + # get model name + my $model_name = $model->Name; + + # Strip prefixed path + my $prefix = defined $params->{prefix} ? $model->getOutputPrefix( $params->{prefix} ) : $model->getOutputPrefix(); + my $suffix = ( defined $params->{suffix} ) ? $params->{suffix} : undef; + if ( $suffix ) + { $prefix .= "_${suffix}"; } + + # split prefix into volume, path and filebase + my ($vol, $path, $filebase) = File::Spec->splitpath($prefix); + + # define mexfile name + my $mex_filebase = "${filebase}_cvode"; + my $mex_filename = "${mex_filebase}.c"; + my $mex_path = File::Spec->catpath($vol,$path,$mex_filename); + + # define m-script files name + my $mscript_filebase = "${filebase}"; + my $mscript_filename = "${mscript_filebase}.m"; + my $mscript_path = File::Spec->catpath($vol,$path,$mscript_filename); + my $mscript_filebase_caps = uc $mscript_filebase; + + # configure options + my $cvode_abstol = 1e-6; + if ( exists $params->{'atol'} ) + { $cvode_abstol = $params->{'atol'}; } + + my $cvode_reltol = 1e-8; + if ( exists $params->{'rtol'} ) + { $cvode_reltol = $params->{'rtol'}; } + + my $cvode_max_num_steps = 2000; + if ( exists $params->{'max_num_steps'} ) + { $cvode_max_num_steps = $params->{'max_num_steps'}; } + + my $cvode_max_err_test_fails = 7; + if ( exists $params->{'max_err_test_fails'} ) + { $cvode_max_err_test_fails = $params->{'max_err_test_fails'}; } + + my $cvode_max_conv_fails = 10; + if ( exists $params->{'max_conv_fails'} ) + { $cvode_max_conv_fails = $params->{'max_conv_fails'}; } + + my $cvode_max_step = '0.0'; + if ( exists $params->{'max_step'} ) + { $cvode_max_step = $params->{'max_step'}; } + + # Stiff = CV_BDF,CV_NEWTON (Default); Non-stiff = CV_ADAMS,CV_FUNCTIONAL + my $cvode_linear_multistep = 'CV_BDF'; + my $cvode_nonlinear_solver = 'CV_NEWTON'; + if ( exists $params->{'stiff'} ) + { + # if stiff is FALSE, then change to CV_ADAMS and CV_FUNCTIONAL + unless ( $params->{'stiff'} ) + { + $cvode_linear_multistep = 'CV_ADAMS'; + $cvode_nonlinear_solver = 'CV_FUNCTIONAL'; + } + } + + # set sparse option (only permitted with CV_NEWTON) + my $cvode_linear_solver; + if ( ($cvode_nonlinear_solver eq 'CV_NEWTON') and ($params->{'sparse'}) ) + { + $cvode_linear_solver = "flag = CVSpgmr(cvode_mem, PREC_NONE, 0);\n" + ." if (check_flag(&flag, \"CVSpgmr\", 1))"; + } + else + { + $cvode_linear_solver = "flag = CVDense(cvode_mem, __N_SPECIES__);\n" + ." if (check_flag(&flag, \"CVDense\", 1))"; + } + + # time options for mscript + my $t_start = 0; + if ( exists $params->{'t_start'} ) + { $t_start = $params->{'t_start'}; } + + my $t_end = 10; + if ( exists $params->{'t_end'} ) + { $t_end = $params->{'t_end'}; } + + my $n_steps = 20; + if ( exists $params->{'n_steps'} ) + { $n_steps = $params->{'n_steps'}; } + + # code snippet for cleaning up dynamic memory before exiting CVODE-MEX + my $cvode_cleanup_memory = "{ \n" + ." N_VDestroy_Serial(expressions);\n" + ." N_VDestroy_Serial(observables);\n" + ." N_VDestroy_Serial(ratelaws); \n" + ." N_VDestroy_Serial(species); \n" + ." CVodeFree(&cvode_mem); \n" + ." return_status[0] = 1; \n" + ." return; \n" + ." } "; + + # Index parameters associated with Constants, ConstantExpressions and Observables + ($err) = $plist->indexParams(); + if ($err) { return $err }; + + # and retrieve a string of expression definitions + my $n_parameters = $plist->countType( 'Constant' ); + my $n_expressions = $plist->countType( 'ConstantExpression' ) + $n_parameters; + (my $calc_expressions_string, $err) = $plist->getCVodeExpressionDefs(); + if ($err) { return $err }; + + # get list of parameter names and defintions for matlab + my $mscript_param_names; + my $mscript_param_values; + ($mscript_param_names, $mscript_param_values, $err) = $plist->getMatlabConstantNames(); + if ($err) { return $err }; + + + # generate CVode references for species + # (Do this now, because we need references to CVode species for Observable definitions and Rxn Rates) + my $n_species = scalar @{$model->SpeciesList->Array}; + + + # retrieve a string of observable definitions + my $n_observables = scalar @{$model->Observables}; + my $calc_observables_string; + ($calc_observables_string, $err) = $plist->getCVodeObservableDefs(); + if ($err) { return $err }; + + # get list of observable names for matlab + my $mscript_observable_names; + ($mscript_observable_names, $err) = $plist->getMatlabObservableNames(); + if ($err) { return $err }; + + # Construct user-defined functions + my $user_fcn_declarations = ''; + my $user_fcn_definitions = ''; + foreach my $param ( @{ $model->ParamList->Array } ) + { + if ( $param->Type eq 'Function' ) + { + # get reference to the actual Function + my $fcn = $param->Ref; + + # don't write function if it depends on a local observable evaluation (this is useless + # since CVode can't do local evaluations) + next if ( $fcn->checkLocalDependency($plist) ); + + # get function declaration, add it to the user_fcn_declarations string + $user_fcn_declarations .= $fcn->toCVodeString( $plist, {fcn_mode=>'declare',indent=>''} ); + + # get function definition + my $fcn_defn = $fcn->toCVodeString( $plist, {fcn_mode=>'define', indent=>''} ); + + # add definition to the user_fcn_definitions string + $user_fcn_definitions .= $fcn_defn . "\n"; + } + } + + # index reactions + ($err) = $model->RxnList->updateIndex( $plist ); + if ($err) { return $err }; + + # retrieve a string of reaction rate definitions + my $n_reactions = scalar @{$model->RxnList->Array}; + my $calc_ratelaws_string; + ($calc_ratelaws_string, $err) = $model->RxnList->getCVodeRateDefs( $plist ); + if ($err) { return $err }; + + + # get stoichiometry matrix (sparse encoding in a hashmap) + my $stoich_hash = {}; + ($err) = $model->RxnList->calcStoichMatrix( $stoich_hash ); + + # retrieve a string of species deriv definitions + my $calc_derivs_string; + ($calc_derivs_string, $err) = $model->SpeciesList->toCVodeString( $model->RxnList, $stoich_hash, $plist ); + if ($err) { return $err }; + + + + # get list of species names and initial value expressions for matlab + my $mscript_species_names; + my $mscript_species_init; + ($mscript_species_names, $mscript_species_init, $err) = $model->SpeciesList->getMatlabSpeciesNames( $model ); + if ($err) { return $err }; + + + ## Set up MATLAB Plot + # fontsizes + my $title_fontsize = 14; + my $axislabel_fontsize = 12; + my $legend_fontsize = 10; + + # generate code snippets for plotting observables or species + my $mscript_plot_labels; + my $mscript_make_plot; + + # get ylabel (either Number of Concentration) + my $ylabel; + if ( $model->SubstanceUnits eq 'Number' ) + { $ylabel = 'number'; } + elsif ( $model->SubstanceUnits eq 'Concentration' ) + { $ylabel = 'concentration'; } + else + { $ylabel = 'number or concentration'; } + + + if ( @{$model->Observables} ) + { # plot observables + $mscript_plot_labels = " observable_labels = { $mscript_observable_names };\n"; + + $mscript_make_plot = " plot(timepoints,observables_out);\n" + ." title('${mscript_filebase} observables','fontSize',${title_fontsize},'Interpreter','none');\n" + ." axis([${t_start} timepoints(end) 0 inf]);\n" + ." legend(observable_labels,'fontSize',${legend_fontsize},'Interpreter','none');\n" + ." xlabel('time','fontSize',${axislabel_fontsize},'Interpreter','none');\n" + ." ylabel('${ylabel}','fontSize',${axislabel_fontsize},'Interpreter','none');\n"; + + } + else + { # plot species + $mscript_plot_labels = " species_labels = { $mscript_species_names };\n"; + + $mscript_make_plot = " plot(timepoints,species_out);\n" + ." title('${mscript_filebase} species','fontSize',${title_fontsize},'Interpreter','none');\n" + ." axis([${t_start} timepoints(end) 0 inf]);\n" + ." legend(species_labels,'fontSize',${legend_fontsize},'Interpreter','none');\n" + ." xlabel('time','fontSize',${axislabel_fontsize},'Interpreter','none');\n" + ." ylabel('${ylabel}','fontSize',${axislabel_fontsize},'Interpreter','none');\n"; + } + + + # open Mexfile and begin printing... + open( Mexfile, ">$mex_path" ) or die "Couldn't open $mex_path: $!\n"; + print Mexfile <<"EOF"; +/* +** ${mex_filename} +** +** Cvode-Mex implementation of BioNetGen model '$model_name'. +** +** Code Adapted from templates provided by Mathworks and Sundials. +** QUESTIONS about the code generator? Email justinshogg\@gmail.com +** +** Requires the CVODE libraries: sundials_cvode and sundials_nvecserial. +** https://computation.llnl.gov/casc/sundials/main.html +** +**----------------------------------------------------------------------------- +** +** COMPILE in MATLAB: +** mex -L -I ... +** -lsundials_nvecserial -lsundials_cvode -lm ${mex_filename} +** +** note1: if cvode is in your library path, you can omit path specifications. +** +** note2: if linker complains about lib stdc++, try removing "-lstdc++" +** from the mex configuration file "gccopts.sh". This should be in the +** matlab bin folder. +** +**----------------------------------------------------------------------------- +** +** EXECUTE in MATLAB: +** [error_status, species_out, observables_out] +** = ${mex_filebase}( timepoints, species_init, parameters ) +** +** timepoints : column vector of time points returned by integrator. +** parameters : row vector of $n_parameters parameters. +** species_init : row vector of $n_species initial species populations. +** +** error_status : 0 if the integrator exits without error, non-zero otherwise. +** species_out : species population trajectories +** (columns correspond to states, rows correspond to time). +** observables_out : observable trajectories +** (columns correspond to observables, rows correspond to time). +*/ + +/* Library headers */ +#include "mex.h" +#include "matrix.h" +#include +#include +#include /* prototypes for CVODE */ +#include /* serial N_Vector */ +#include /* prototype for CVDense */ +#include /* prototype for CVSpgmr */ + +/* Problem Dimensions */ +#define __N_PARAMETERS__ $n_parameters +#define __N_EXPRESSIONS__ $n_expressions +#define __N_OBSERVABLES__ $n_observables +#define __N_RATELAWS__ $n_reactions +#define __N_SPECIES__ $n_species + +/* core function declarations */ +void mexFunction ( int nlhs, mxArray *plhs[], int nrhs, const mxArray *prhs[] ); +int check_flag ( void *flagvalue, char *funcname, int opt ); +void calc_expressions ( N_Vector expressions, double * parameters ); +void calc_observables ( N_Vector observables, N_Vector species, N_Vector expressions ); +void calc_ratelaws ( N_Vector ratelaws, N_Vector species, N_Vector expressions, N_Vector observables ); +int calc_species_deriv ( realtype time, N_Vector species, N_Vector Dspecies, void * f_data ); + +/* user-defined function declarations */ +$user_fcn_declarations + +/* user-defined function definitions */ +$user_fcn_definitions + +/* Calculate expressions */ +void +calc_expressions ( N_Vector expressions, double * parameters ) +{ +$calc_expressions_string +} + +/* Calculate observables */ +void +calc_observables ( N_Vector observables, N_Vector species, N_Vector expressions ) +{ +$calc_observables_string +} + +/* Calculate ratelaws */ +void +calc_ratelaws ( N_Vector ratelaws, N_Vector species, N_Vector expressions, N_Vector observables ) +{ +$calc_ratelaws_string +} + + +/* Calculate species derivatives */ +int +calc_species_deriv ( realtype time, N_Vector species, N_Vector Dspecies, void * f_data ) +{ + int return_val; + N_Vector * temp_data; + + N_Vector expressions; + N_Vector observables; + N_Vector ratelaws; + + /* cast temp_data */ + temp_data = (N_Vector*)f_data; + + /* sget ratelaws Vector */ + expressions = temp_data[0]; + observables = temp_data[1]; + ratelaws = temp_data[2]; + + /* calculate observables */ + calc_observables( observables, species, expressions ); + + /* calculate ratelaws */ + calc_ratelaws( ratelaws, species, expressions, observables ); + + /* calculate derivatives */ +$calc_derivs_string + + return(0); +} + + +/* +** ======== +** main MEX +** ======== +*/ +void mexFunction( int nlhs, mxArray * plhs[], int nrhs, const mxArray * prhs[] ) +{ + /* variables */ + double * return_status; + double * species_out; + double * observables_out; + double * parameters; + double * species_init; + double * timepoints; + size_t n_timepoints; + size_t i; + size_t j; + + /* intermediate data vectors */ + N_Vector expressions; + N_Vector observables; + N_Vector ratelaws; + + /* array to hold pointers to data vectors */ + N_Vector temp_data[3]; + + /* CVODE specific variables */ + realtype reltol; + realtype abstol; + realtype time; + N_Vector species; + void * cvode_mem; + int flag; + + /* check number of input/output arguments */ + if (nlhs != 3) + { mexErrMsgTxt("syntax: [err_flag, species_out, obsv_out] = network_mex( timepoints, species_init, params )"); } + if (nrhs != 3) + { mexErrMsgTxt("syntax: [err_flag, species_out, obsv_out] = network_mex( timepoints, species_init, params )"); } + + + /* make sure timepoints has correct dimensions */ + if ( (mxGetM(prhs[0]) < 2) || (mxGetN(prhs[0]) != 1) ) + { mexErrMsgTxt("TIMEPOINTS must be a column vector with 2 or more elements."); } + + /* make sure species_init has correct dimensions */ + if ( (mxGetM(prhs[1]) != 1) || (mxGetN(prhs[1]) != __N_SPECIES__) ) + { mexErrMsgTxt("SPECIES_INIT must be a row vector with $n_species elements."); } + + /* make sure params has correct dimensions */ + if ( (mxGetM(prhs[2]) != 1) || (mxGetN(prhs[2]) != __N_PARAMETERS__) ) + { mexErrMsgTxt("PARAMS must be a column vector with $n_parameters elements."); } + + /* get pointers to input arrays */ + timepoints = mxGetPr(prhs[0]); + species_init = mxGetPr(prhs[1]); + parameters = mxGetPr(prhs[2]); + + /* get number of timepoints */ + n_timepoints = mxGetM(prhs[0]); + + /* Create an mxArray for output trajectories */ + plhs[0] = mxCreateDoubleMatrix(1, 1, mxREAL ); + plhs[1] = mxCreateDoubleMatrix(n_timepoints, __N_SPECIES__, mxREAL); + plhs[2] = mxCreateDoubleMatrix(n_timepoints, __N_OBSERVABLES__, mxREAL); + + /* get pointers to output arrays */ + return_status = mxGetPr(plhs[0]); + species_out = mxGetPr(plhs[1]); + observables_out = mxGetPr(plhs[2]); + + /* initialize intermediate data vectors */ + expressions = NULL; + expressions = N_VNew_Serial(__N_EXPRESSIONS__); + if (check_flag((void *)expressions, "N_VNew_Serial", 0)) + { + return_status[0] = 1; + return; + } + + observables = NULL; + observables = N_VNew_Serial(__N_OBSERVABLES__); + if (check_flag((void *)observables, "N_VNew_Serial", 0)) + { + N_VDestroy_Serial(expressions); + return_status[0] = 1; + return; + } + + ratelaws = NULL; + ratelaws = N_VNew_Serial(__N_RATELAWS__); + if (check_flag((void *)ratelaws, "N_VNew_Serial", 0)) + { + N_VDestroy_Serial(expressions); + N_VDestroy_Serial(observables); + return_status[0] = 1; + return; + } + + /* set up pointers to intermediate data vectors */ + temp_data[0] = expressions; + temp_data[1] = observables; + temp_data[2] = ratelaws; + + /* calculate expressions (expressions are constant, so only do this once!) */ + calc_expressions( expressions, parameters ); + + + /* SOLVE model equations! */ + species = NULL; + cvode_mem = NULL; + + /* Set the scalar relative tolerance */ + reltol = $cvode_reltol; + abstol = $cvode_abstol; + + /* Create serial vector for Species */ + species = N_VNew_Serial(__N_SPECIES__); + if (check_flag((void *)species, "N_VNew_Serial", 0)) + { + N_VDestroy_Serial(expressions); + N_VDestroy_Serial(observables); + N_VDestroy_Serial(ratelaws); + return_status[0] = 1; + return; + } + for ( i = 0; i < __N_SPECIES__; i++ ) + { NV_Ith_S(species,i) = species_init[i]; } + + /* write initial species populations into species_out */ + for ( i = 0; i < __N_SPECIES__; i++ ) + { species_out[i*n_timepoints] = species_init[i]; } + + /* write initial observables populations into species_out */ + calc_observables( observables, species, expressions ); + for ( i = 0; i < __N_OBSERVABLES__; i++ ) + { observables_out[i*n_timepoints] = NV_Ith_S(observables,i); } + + /* Call CVodeCreate to create the solver memory: + * CV_ADAMS or CV_BDF is the linear multistep method + * CV_FUNCTIONAL or CV_NEWTON is the nonlinear solver iteration + * A pointer to the integrator problem memory is returned and stored in cvode_mem. + */ + cvode_mem = CVodeCreate($cvode_linear_multistep, $cvode_nonlinear_solver); + if (check_flag((void *)cvode_mem, "CVodeCreate", 0)) + $cvode_cleanup_memory + + + + /* Call CVodeInit to initialize the integrator memory: + * cvode_mem is the pointer to the integrator memory returned by CVodeCreate + * rhs_func is the user's right hand side function in y'=f(t,y) + * T0 is the initial time + * y is the initial dependent variable vector + */ + flag = CVodeInit(cvode_mem, calc_species_deriv, timepoints[0], species); + if (check_flag(&flag, "CVodeInit", 1)) + $cvode_cleanup_memory + + /* Set scalar relative and absolute tolerances */ + flag = CVodeSStolerances(cvode_mem, reltol, abstol); + if (check_flag(&flag, "CVodeSStolerances", 1)) + $cvode_cleanup_memory + + /* pass params to rhs_func */ + flag = CVodeSetUserData(cvode_mem, &temp_data); + if (check_flag(&flag, "CVodeSetFdata", 1)) + $cvode_cleanup_memory + + /* select linear solver */ + $cvode_linear_solver + $cvode_cleanup_memory + + flag = CVodeSetMaxNumSteps(cvode_mem, $cvode_max_num_steps); + if (check_flag(&flag, "CVodeSetMaxNumSteps", 1)) + $cvode_cleanup_memory + + flag = CVodeSetMaxErrTestFails(cvode_mem, $cvode_max_err_test_fails); + if (check_flag(&flag, "CVodeSetMaxErrTestFails", 1)) + $cvode_cleanup_memory + + flag = CVodeSetMaxConvFails(cvode_mem, $cvode_max_conv_fails); + if (check_flag(&flag, "CVodeSetMaxConvFails", 1)) + $cvode_cleanup_memory + + flag = CVodeSetMaxStep(cvode_mem, $cvode_max_step); + if (check_flag(&flag, "CVodeSetMaxStep", 1)) + $cvode_cleanup_memory + + /* integrate to each timepoint */ + for ( i=1; i < n_timepoints; i++ ) + { + flag = CVode(cvode_mem, timepoints[i], species, &time, CV_NORMAL); + if (check_flag(&flag, "CVode", 1)) + { + N_VDestroy_Serial(expressions); + N_VDestroy_Serial(observables); + N_VDestroy_Serial(ratelaws); + N_VDestroy_Serial(species); + CVodeFree(&cvode_mem); + return_status[0] = 1; + return; + } + + /* copy species output from nvector to matlab array */ + for ( j = 0; j < __N_SPECIES__; j++ ) + { species_out[j*n_timepoints + i] = NV_Ith_S(species,j); } + + /* copy observables output from nvector to matlab array */ + calc_observables( observables, species, expressions ); + for ( j = 0; j < __N_OBSERVABLES__; j++ ) + { observables_out[j*n_timepoints + i] = NV_Ith_S(observables,j); } + } + + /* Free vectors */ + N_VDestroy_Serial(expressions); + N_VDestroy_Serial(observables); + N_VDestroy_Serial(ratelaws); + N_VDestroy_Serial(species); + + /* Free integrator memory */ + CVodeFree(&cvode_mem); + + return; +} + + +/* Check function return value... + * opt == 0 means SUNDIALS function allocates memory so check if + * returned NULL pointer + * opt == 1 means SUNDIALS function returns a flag so check if + * flag >= 0 + * opt == 2 means function allocates memory so check if returned + * NULL pointer + */ +int check_flag(void *flagvalue, char *funcname, int opt) +{ + int *errflag; + + /* Check if SUNDIALS function returned NULL pointer - no memory allocated */ + if (opt == 0 && flagvalue == NULL) + { + mexPrintf( "\\nSUNDIALS_ERROR: %s() failed - returned NULL pointer\\n", funcname ); + return(1); + } + + /* Check if flag < 0 */ + else if (opt == 1) + { + errflag = (int *) flagvalue; + if (*errflag < 0) + { + mexPrintf( "\\nSUNDIALS_ERROR: %s() failed with flag = %d\\n", funcname, *errflag ); + return(1); + } + } + + /* Check if function returned NULL pointer - no memory allocated */ + else if (opt == 2 && flagvalue == NULL) + { + mexPrintf( "\\nMEMORY_ERROR: %s() failed - returned NULL pointer\\n", funcname ); + return(1); + } + + return(0); +} +EOF + close(Mexfile); + + + + # open Mexfile and begin printing... + open( Mscript, ">$mscript_path" ) or die "Couldn't open $mscript_path: $!\n"; + print Mscript <<"EOF"; +function [err, timepoints, species_out, observables_out ] = ${mscript_filebase}( timepoints, species_init, parameters, suppress_plot ) +%${mscript_filebase_caps} Integrate reaction network and plot observables. +% Integrates the reaction network corresponding to the BioNetGen model +% '${model_name}' and then (optionally) plots the observable trajectories, +% or species trajectories if no observables are defined. Trajectories are +% generated using either default or user-defined parameters and initial +% species values. Integration is performed by the CVode library interfaced +% to MATLAB via the MEX interface. Before running this script, the model +% source in file ${mex_filename} must be compiled (see that file for details). +% ${mscript_filebase_caps} returns an error value, a vector of timepoints, +% species trajectories, and observable trajectories. +% +% [err, timepoints, species_out, observables_out] +% = ${mscript_filebase}( timepoints, species_init, parameters, suppress_plot ) +% +% INPUTS: +% ------- +% timepoints : column vector of time points returned by integrator. +% species_init : row vector of $n_species initial species populations. +% parameters : row vector of $n_parameters model parameters. +% suppress_plot : 0 if a plot is desired (default), 1 if plot is suppressed. +% +% Note: to specify default value for an input argument, pass the empty array. +% +% OUTPUTS: +% -------- +% err : 0 if the integrator exits without error, non-zero otherwise. +% timepoints : a row vector of timepoints returned by the integrator. +% species_out : array of species population trajectories +% (columns correspond to species, rows correspond to time). +% observables_out : array of observable trajectories +% (columns correspond to observables, rows correspond to time). +% +% QUESTIONS about the BNG Mfile generator? Email justinshogg\@gmail.com + + + +%% Process input arguments + +% define any missing arguments +if ( nargin < 1 ) + timepoints = []; +end + +if ( nargin < 2 ) + species_init = []; +end + +if ( nargin < 3 ) + parameters = []; +end + +if ( nargin < 4 ) + suppress_plot = 0; +end + + +% initialize outputs (to avoid error msgs if script terminates early +err = 0; +species_out = []; +observables_out = []; + + +% setup default parameters, if necessary +if ( isempty(parameters) ) + parameters = [ $mscript_param_values ]; +end +% check that parameters has proper dimensions +if ( size(parameters,1) ~= 1 || size(parameters,2) ~= $n_parameters ) + fprintf( 1, 'Error: size of parameter argument is invalid! Correct size = [1 $n_parameters].\\n' ); + err = 1; + return; +end + +% setup default initial values, if necessary +if ( isempty(species_init) ) + species_init = initialize_species( parameters ); +end +% check that species_init has proper dimensions +if ( size(species_init,1) ~= 1 || size(species_init,2) ~= $n_species ) + fprintf( 1, 'Error: size of species_init argument is invalid! Correct size = [1 $n_species].\\n' ); + err = 1; + return; +end + +% setup default timepoints, if necessary +if ( isempty(timepoints) ) + timepoints = linspace($t_start,$t_end,$n_steps+1)'; +end +% check that timepoints has proper dimensions +if ( size(timepoints,1) < 2 || size(timepoints,2) ~= 1 ) + fprintf( 1, 'Error: size of timepoints argument is invalid! Correct size = [t 1], t>1.\\n' ); + err = 1; + return; +end + +% setup default suppress_plot, if necessary +if ( isempty(suppress_plot) ) + suppress_plot = 0; +end +% check that suppress_plot has proper dimensions +if ( size(suppress_plot,1) ~= 1 || size(suppress_plot,2) ~= 1 ) + fprintf( 1, 'Error: suppress_plots argument should be a scalar!\\n' ); + err = 1; + return; +end + +% define parameter labels (this is for the user's reference!) +param_labels = { $mscript_param_names }; + + + +%% Integrate Network Model +try + % run simulation + [err, species_out, observables_out] = ${mex_filebase}( timepoints, species_init, parameters ); +catch + fprintf( 1, 'Error: some problem integrating ODE network! (CVODE exitflag %d)\\n', err ); + err = 1; + return; +end + + + +%% Plot Output, if desired + +if ( ~suppress_plot ) + + % define plot labels +$mscript_plot_labels + % construct figure +$mscript_make_plot +end + + + +%~~~~~~~~~~~~~~~~~~~~~% +% END of main script! % +%~~~~~~~~~~~~~~~~~~~~~% + + + +% initialize species function +function [species_init] = initialize_species( params ) + + species_init = zeros(1,$n_species); +$mscript_species_init +end + + +end +EOF + close Mscript; + print "Wrote Mexfile $mex_path and M-file script $mscript_path.\n"; + return (); +} + + + +### +### +### + + +sub writeCPPfile +{ + my $model = shift; + my $params = (@_) ? shift : {}; + + # a place to hold errors + my $err; + + # nothing to do if NO_EXEC is true + return '' if $BNGModel::NO_EXEC; + + # nothing to do if there are no reactions + if ( @{$model->RxnList->Array}==0 ) + { + return "writeMexfile() has nothing to do: no reactions in current model. " + ."Did you remember to call generate_network() before attempting to " + ."write network output?"; + } + + # get reference to parameter list + my $plist = $model->ParamList; + + # get model name + my $model_name = $model->Name; + + # Strip prefixed path + my $prefix = defined $params->{prefix} ? $model->getOutputPrefix( $params->{prefix} ) : $model->getOutputPrefix(); + my $suffix = ( defined $params->{suffix} ) ? $params->{suffix} : undef; + if ( $suffix ) + { $prefix .= "_${suffix}"; } + + # split prefix into volume, path and filebase + my ($vol, $path, $filebase) = File::Spec->splitpath($prefix); + + # define mexfile name + my $cpp_filebase = "${filebase}_cvode"; + my $cpp_filename = "${cpp_filebase}.h"; + my $cpp_path = File::Spec->catpath($vol,$path,$cpp_filename); + + # configure options + my $cvode_abstol = 1e-6; + if ( exists $params->{'atol'} ) + { $cvode_abstol = $params->{'atol'}; } + + my $cvode_reltol = 1e-8; + if ( exists $params->{'rtol'} ) + { $cvode_reltol = $params->{'rtol'}; } + + my $cvode_max_num_steps = 2000; + if ( exists $params->{'max_num_steps'} ) + { $cvode_max_num_steps = $params->{'max_num_steps'}; } + + my $cvode_max_err_test_fails = 7; + if ( exists $params->{'max_err_test_fails'} ) + { $cvode_max_err_test_fails = $params->{'max_err_test_fails'}; } + + my $cvode_max_conv_fails = 10; + if ( exists $params->{'max_conv_fails'} ) + { $cvode_max_conv_fails = $params->{'max_conv_fails'}; } + + my $cvode_max_step = '0.0'; + if ( exists $params->{'max_step'} ) + { $cvode_max_step = $params->{'max_step'}; } + + # Stiff = CV_BDF,CV_NEWTON (Default); Non-stiff = CV_ADAMS,CV_FUNCTIONAL + my $cvode_linear_multistep = 'CV_BDF'; + my $cvode_nonlinear_solver = 'CV_NEWTON'; + if ( exists $params->{'stiff'} ) + { + # if stiff is FALSE, then change to CV_ADAMS and CV_FUNCTIONAL + unless ( $params->{'stiff'} ) + { + $cvode_linear_multistep = 'CV_ADAMS'; + $cvode_nonlinear_solver = 'CV_FUNCTIONAL'; + } + } + + # set sparse option (only permitted with CV_NEWTON) + my $cvode_linear_solver; + if ( ($cvode_nonlinear_solver eq 'CV_NEWTON') and ($params->{'sparse'}) ) + { + $cvode_linear_solver = "flag = CVSpgmr(cvode_mem, PREC_NONE, 0);\n" + ." if (check_flag(&flag, \"CVSpgmr\", 1))"; + } + else + { + $cvode_linear_solver = "flag = CVDense(cvode_mem, __N_SPECIES__);\n" + ." if (check_flag(&flag, \"CVDense\", 1))"; + } + + # time options for mscript + my $t_start = 0; + if ( exists $params->{'t_start'} ) + { $t_start = $params->{'t_start'}; } + + my $t_end = 10; + if ( exists $params->{'t_end'} ) + { $t_end = $params->{'t_end'}; } + + my $n_steps = 20; + if ( exists $params->{'n_steps'} ) + { $n_steps = $params->{'n_steps'}; } + + # code snippet for cleaning up dynamic memory before exiting CVODE-MEX + my $cvode_cleanup_memory = "{ \n" + ." N_VDestroy_Serial(expressions);\n" + ." N_VDestroy_Serial(observables);\n" + ." N_VDestroy_Serial(ratelaws); \n" + ." N_VDestroy_Serial(species); \n" + ." CVodeFree(&cvode_mem); \n" + ." return_status = 1; \n" + ." return Result {return_status, species_out, observables_out}; \n" + ." } "; + + # Index parameters associated with Constants, ConstantExpressions and Observables + ($err) = $plist->indexParams(); + if ($err) { return $err }; + + # and retrieve a string of expression definitions + my $n_parameters = $plist->countType( 'Constant' ); + my $n_expressions = $plist->countType( 'ConstantExpression' ) + $n_parameters; + (my $calc_expressions_string, $err) = $plist->getCVodeExpressionDefs(); + if ($err) { return $err }; + + # generate CVode references for species + # (Do this now, because we need references to CVode species for Observable definitions and Rxn Rates) + my $n_species = scalar @{$model->SpeciesList->Array}; + + + # retrieve a string of observable definitions + my $n_observables = scalar @{$model->Observables}; + my $calc_observables_string; + ($calc_observables_string, $err) = $plist->getCVodeObservableDefs(); + if ($err) { return $err }; + + # Construct user-defined functions + my $user_fcn_declarations = ''; + my $user_fcn_definitions = ''; + foreach my $param ( @{ $model->ParamList->Array } ) + { + if ( $param->Type eq 'Function' ) + { + # get reference to the actual Function + my $fcn = $param->Ref; + + # don't write function if it depends on a local observable evaluation (this is useless + # since CVode can't do local evaluations) + next if ( $fcn->checkLocalDependency($plist) ); + + # get function declaration, add it to the user_fcn_declarations string + $user_fcn_declarations .= $fcn->toCVodeString( $plist, {fcn_mode=>'declare',indent=>''} ); + + # get function definition + my $fcn_defn = $fcn->toCVodeString( $plist, {fcn_mode=>'define', indent=>''} ); + + # add definition to the user_fcn_definitions string + $user_fcn_definitions .= $fcn_defn . "\n"; + } + } + + # index reactions + ($err) = $model->RxnList->updateIndex( $plist ); + if ($err) { return $err }; + + # retrieve a string of reaction rate definitions + my $n_reactions = scalar @{$model->RxnList->Array}; + my $calc_ratelaws_string; + ($calc_ratelaws_string, $err) = $model->RxnList->getCVodeRateDefs( $plist ); + if ($err) { return $err }; + + + # get stoichiometry matrix (sparse encoding in a hashmap) + my $stoich_hash = {}; + ($err) = $model->RxnList->calcStoichMatrix( $stoich_hash ); + + # retrieve a string of species deriv definitions + my $calc_derivs_string; + ($calc_derivs_string, $err) = $model->SpeciesList->toCVodeString( $model->RxnList, $stoich_hash, $plist ); + if ($err) { return $err }; + + # open Mexfile and begin printing... + open( Cppfile, ">$cpp_path" ) or die "Couldn't open $cpp_path: $!\n"; + print Cppfile <<"EOF"; +/* +** ${cpp_filename} +** +** Cvode-C++ implementation of BioNetGen model '$model_name'. +** +** Code Adapted from templates provided by Mathworks and Sundials. +** +** Requires the CVODE libraries: sundials_cvode and sundials_nvecserial. +** https://computation.llnl.gov/casc/sundials/main.html +** +**----------------------------------------------------------------------------- +** +** Compilation notes: +** +** include the model in your C++ file with +** +** #include <$model_name.h> +** +** and compile with +** +** g++ -I/path/to/$model_name.h -c your_script.cpp +** g++ your_script.o -L/path/to/sundials/lib -lsundials_cvode -lsundials_nvecserial -o run_model +** ./run_model +** +** note1: if cvode is in your library path, you can omit path specifications. +** +**----------------------------------------------------------------------------- +** +** Usage in C++ : +** +** Result result; +** vector time_points; +** vector species_initial_values; +** vector parameters; +** result = simulate(timepoints, species_initial_values, parameters); +** +** result.status: is the simulation status +** result.species: is the time series for each species, result.species[N][t] +** is the value of species N at time t +** result.observables: is the time series for each observable, result.observables[N][t] +** is the value of observable N at time t +*/ + +/* Library headers */ +#include +#include +#include +#include + +#include /* prototypes for CVODE */ +#include /* serial N_Vector */ +#include /* prototype for CVDense */ +#include /* prototype for CVSpgmr */ + +using namespace std; + +/* Problem Dimensions */ +#define __N_PARAMETERS__ $n_parameters +#define __N_EXPRESSIONS__ $n_expressions +#define __N_OBSERVABLES__ $n_observables +#define __N_RATELAWS__ $n_reactions +#define __N_SPECIES__ $n_species + +/* user-defined function declarations */ +$user_fcn_declarations + +/* user-defined function definitions */ +$user_fcn_definitions + +/* Calculate expressions */ +void +calc_expressions ( N_Vector expressions, double * parameters ) +{ +$calc_expressions_string +} + +/* Calculate observables */ +void +calc_observables ( N_Vector observables, N_Vector species, N_Vector expressions ) +{ +$calc_observables_string +} + +/* Calculate ratelaws */ +void +calc_ratelaws ( N_Vector ratelaws, N_Vector species, N_Vector expressions, N_Vector observables ) +{ +$calc_ratelaws_string +} + + +/* Calculate species derivatives */ +int +calc_species_deriv ( realtype time, N_Vector species, N_Vector Dspecies, void * f_data ) +{ + int return_val; + N_Vector * temp_data; + + N_Vector expressions; + N_Vector observables; + N_Vector ratelaws; + + /* cast temp_data */ + temp_data = (N_Vector*)f_data; + + /* sget ratelaws Vector */ + expressions = temp_data[0]; + observables = temp_data[1]; + ratelaws = temp_data[2]; + + /* calculate observables */ + calc_observables( observables, species, expressions ); + + /* calculate ratelaws */ + calc_ratelaws( ratelaws, species, expressions, observables ); + + /* calculate derivatives */ +$calc_derivs_string + + return(0); +} + +/* Check function return value... + * opt == 0 means SUNDIALS function allocates memory so check if + * returned NULL pointer + * opt == 1 means SUNDIALS function returns a flag so check if + * flag >= 0 + * opt == 2 means function allocates memory so check if returned + * NULL pointer + */ +int check_flag(void *flagvalue, char *funcname, int opt) +{ + int *errflag; + + /* Check if SUNDIALS function returned NULL pointer - no memory allocated */ + if (opt == 0 && flagvalue == NULL) + { + cout << "\\nSUNDIALS_ERROR: " << funcname << "() failed - returned NULL pointer" << endl; + return(1); + } + + /* Check if flag < 0 */ + else if (opt == 1) + { + errflag = (int *) flagvalue; + if (*errflag < 0) + { + cout << "\\nSUNDIALS_ERROR: " << funcname << "() failed with flag = " << errflag << endl; + return(1); + } + } + + /* Check if function returned NULL pointer - no memory allocated */ + else if (opt == 2 && flagvalue == NULL) + { + cout << "\\nMEMORY_ERROR: " << funcname << "() failed - returned NULL pointer" << endl; + return(1); + } + + return(0); +} + +/* +** ======== +** result structure +** ======== +*/ + +struct Result { + int status; + vector< vector > species; + vector< vector > observables; +}; + +/* +** ======== +** main simulate command +** ======== +*/ +Result simulate( vector timepoints, vector species_init, vector parameters) +{ + int n_timepoints; + size_t i; + size_t j; + + /* intermediate data vectors */ + N_Vector expressions; + N_Vector observables; + N_Vector ratelaws; + + /* array to hold pointers to data vectors */ + N_Vector temp_data[3]; + + /* CVODE specific variables */ + realtype reltol; + realtype abstol; + realtype time; + N_Vector species; + void * cvode_mem; + int flag; + + /* make sure timepoints has correct dimensions */ + if ( (timepoints.size() < 2) ) + { cout << "TIMEPOINTS must be a vector with 2 or more elements." < > species_out( __N_SPECIES__ , vector (n_timepoints, 0)); + vector< vector > observables_out( __N_OBSERVABLES__ , vector (n_timepoints, 0)); + + double * ptr_parameters = ¶meters[0]; + double * ptr_timepoints = &timepoints[0]; + double * ptr_species_init = &species_init[0]; + + /* initialize intermediate data vectors */ + expressions = NULL; + expressions = N_VNew_Serial(__N_EXPRESSIONS__); + if (check_flag((void *)expressions, "N_VNew_Serial", 0)) + { + return_status = 1; + return Result {return_status, species_out, observables_out}; + } + + observables = NULL; + observables = N_VNew_Serial(__N_OBSERVABLES__); + if (check_flag((void *)observables, "N_VNew_Serial", 0)) + { + N_VDestroy_Serial(expressions); + return_status = 1; + return Result {return_status, species_out, observables_out}; + } + + ratelaws = NULL; + ratelaws = N_VNew_Serial(__N_RATELAWS__); + if (check_flag((void *)ratelaws, "N_VNew_Serial", 0)) + { + N_VDestroy_Serial(expressions); + N_VDestroy_Serial(observables); + return_status = 1; + return Result {return_status, species_out, observables_out}; + } + + /* set up pointers to intermediate data vectors */ + temp_data[0] = expressions; + temp_data[1] = observables; + temp_data[2] = ratelaws; + + /* calculate expressions (expressions are constant, so only do this once!) */ + calc_expressions( expressions, ptr_parameters ); + + /* SOLVE model equations! */ + species = NULL; + cvode_mem = NULL; + + /* Set the scalar relative tolerance */ + reltol = $cvode_reltol; + abstol = $cvode_abstol; + + /* Create serial vector for Species */ + species = N_VNew_Serial(__N_SPECIES__); + if (check_flag((void *)species, "N_VNew_Serial", 0)) + { + N_VDestroy_Serial(expressions); + N_VDestroy_Serial(observables); + N_VDestroy_Serial(ratelaws); + return_status = 1; + return Result {return_status, species_out, observables_out}; + } + for ( i = 0; i < __N_SPECIES__; i++ ) + { NV_Ith_S(species,i) = species_init[i]; } + + /* write initial species populations into species_out */ + for ( i = 0; i < __N_SPECIES__; i++ ) + { species_out[i][0] = species_init[i]; } + + /* write initial observables populations into species_out */ + calc_observables( observables, species, expressions ); + for ( i = 0; i < __N_OBSERVABLES__; i++ ) + { observables_out[i][0] = NV_Ith_S(observables,i); } + + /* Call CVodeCreate to create the solver memory: + * CV_ADAMS or CV_BDF is the linear multistep method + * CV_FUNCTIONAL or CV_NEWTON is the nonlinear solver iteration + * A pointer to the integrator problem memory is returned and stored in cvode_mem. + */ + cvode_mem = CVodeCreate($cvode_linear_multistep, $cvode_nonlinear_solver); + if (check_flag((void *)cvode_mem, "CVodeCreate", 0)) + $cvode_cleanup_memory + + + + /* Call CVodeInit to initialize the integrator memory: + * cvode_mem is the pointer to the integrator memory returned by CVodeCreate + * rhs_func is the user's right hand side function in y'=f(t,y) + * T0 is the initial time + * y is the initial dependent variable vector + */ + flag = CVodeInit(cvode_mem, calc_species_deriv, timepoints[0], species); + if (check_flag(&flag, "CVodeInit", 1)) + $cvode_cleanup_memory + + /* Set scalar relative and absolute tolerances */ + flag = CVodeSStolerances(cvode_mem, reltol, abstol); + if (check_flag(&flag, "CVodeSStolerances", 1)) + $cvode_cleanup_memory + + /* pass params to rhs_func */ + flag = CVodeSetUserData(cvode_mem, &temp_data); + if (check_flag(&flag, "CVodeSetFdata", 1)) + $cvode_cleanup_memory + + /* select linear solver */ + $cvode_linear_solver + $cvode_cleanup_memory + + flag = CVodeSetMaxNumSteps(cvode_mem, $cvode_max_num_steps); + if (check_flag(&flag, "CVodeSetMaxNumSteps", 1)) + $cvode_cleanup_memory + + flag = CVodeSetMaxErrTestFails(cvode_mem, $cvode_max_err_test_fails); + if (check_flag(&flag, "CVodeSetMaxErrTestFails", 1)) + $cvode_cleanup_memory + + flag = CVodeSetMaxConvFails(cvode_mem, $cvode_max_conv_fails); + if (check_flag(&flag, "CVodeSetMaxConvFails", 1)) + $cvode_cleanup_memory + + flag = CVodeSetMaxStep(cvode_mem, $cvode_max_step); + if (check_flag(&flag, "CVodeSetMaxStep", 1)) + $cvode_cleanup_memory + + /* integrate to each timepoint */ + for ( i=1; i < n_timepoints; i++ ) + { + flag = CVode(cvode_mem, timepoints[i], species, &time, CV_NORMAL); + if (check_flag(&flag, "CVode", 1)) + { + N_VDestroy_Serial(expressions); + N_VDestroy_Serial(observables); + N_VDestroy_Serial(ratelaws); + N_VDestroy_Serial(species); + CVodeFree(&cvode_mem); + return_status = 1; + return Result {return_status, species_out, observables_out} ; + } + + /* copy species output from nvector to matlab array */ + for ( j = 0; j < __N_SPECIES__; j++ ) + { species_out[j][i] = NV_Ith_S(species,j); } + + /* copy observables output from nvector to matlab array */ + calc_observables( observables, species, expressions ); + for ( j = 0; j < __N_OBSERVABLES__; j++ ) + { observables_out[j][i] = NV_Ith_S(observables,j); } + } + + /* Free vectors */ + N_VDestroy_Serial(expressions); + N_VDestroy_Serial(observables); + N_VDestroy_Serial(ratelaws); + N_VDestroy_Serial(species); + + /* Free integrator memory */ + CVodeFree(&cvode_mem); + + /* return status, species and obserables */ + return Result {return_status, species_out, observables_out}; +} +EOF + close(Cppfile); + + + + # open Mexfile and begin printing... + + print "Wrote Cppfile $cpp_path.\n"; + return (); +} + + +### +### +### + + +sub writeCPYfile +{ + my $model = shift; + my $params = (@_) ? shift : {}; + + # a place to hold errors + my $err; + + # nothing to do if NO_EXEC is true + return '' if $BNGModel::NO_EXEC; + + # nothing to do if there are no reactions + if ( @{$model->RxnList->Array}==0 ) + { + return "writeCPYfile() has nothing to do: no reactions in current model. " + ."Did you remember to call generate_network() before attempting to " + ."write network output?"; + } + + # get reference to parameter list + my $plist = $model->ParamList; + + # get model name + my $model_name = $model->Name; + + # Strip prefixed path + my $prefix = defined $params->{prefix} ? $model->getOutputPrefix( $params->{prefix} ) : $model->getOutputPrefix(); + my $suffix = ( defined $params->{suffix} ) ? $params->{suffix} : undef; + if ( $suffix ) + { $prefix .= "_${suffix}"; } + + # split prefix into volume, path and filebase + my ($vol, $path, $filebase) = File::Spec->splitpath($prefix); + + # define c file name + my $cpy_filebase = "${filebase}_cvode_py"; + my $cpy_filename = "${cpy_filebase}.c"; + my $cpy_path = File::Spec->catpath($vol,$path,$cpy_filename); + + # configure options + my $cvode_abstol = 1e-6; + if ( exists $params->{'atol'} ) + { $cvode_abstol = $params->{'atol'}; } + + my $cvode_reltol = 1e-8; + if ( exists $params->{'rtol'} ) + { $cvode_reltol = $params->{'rtol'}; } + + my $cvode_max_num_steps = 2000; + if ( exists $params->{'max_num_steps'} ) + { $cvode_max_num_steps = $params->{'max_num_steps'}; } + + my $cvode_max_err_test_fails = 7; + if ( exists $params->{'max_err_test_fails'} ) + { $cvode_max_err_test_fails = $params->{'max_err_test_fails'}; } + + my $cvode_max_conv_fails = 10; + if ( exists $params->{'max_conv_fails'} ) + { $cvode_max_conv_fails = $params->{'max_conv_fails'}; } + + my $cvode_max_step = '0.0'; + if ( exists $params->{'max_step'} ) + { $cvode_max_step = $params->{'max_step'}; } + + # Stiff = CV_BDF,CV_NEWTON (Default); Non-stiff = CV_ADAMS,CV_FUNCTIONAL + my $cvode_linear_multistep = 'CV_BDF'; + my $cvode_nonlinear_solver = 'CV_NEWTON'; + if ( exists $params->{'stiff'} ) + { + # if stiff is FALSE, then change to CV_ADAMS and CV_FUNCTIONAL + unless ( $params->{'stiff'} ) + { + $cvode_linear_multistep = 'CV_ADAMS'; + $cvode_nonlinear_solver = 'CV_FUNCTIONAL'; + } + } + + # set sparse option (only permitted with CV_NEWTON) + my $cvode_linear_solver; + if ( ($cvode_nonlinear_solver eq 'CV_NEWTON') and ($params->{'sparse'}) ) + { + $cvode_linear_solver = "flag = CVSpgmr(cvode_mem, PREC_NONE, 0);\n" + ." if (check_flag(&flag, \"CVSpgmr\", 1))"; + } + else + { + $cvode_linear_solver = "flag = CVDense(cvode_mem, __N_SPECIES__);\n" + ." if (check_flag(&flag, \"CVDense\", 1))"; + } + + # time options for mscript + my $t_start = 0; + if ( exists $params->{'t_start'} ) + { $t_start = $params->{'t_start'}; } + + my $t_end = 10; + if ( exists $params->{'t_end'} ) + { $t_end = $params->{'t_end'}; } + + my $n_steps = 20; + if ( exists $params->{'n_steps'} ) + { $n_steps = $params->{'n_steps'}; } + + # code snippet for cleaning up dynamic memory before exiting CVODE + my $cvode_cleanup_memory = "{ \n" + ." N_VDestroy_Serial(expressions);\n" + ." N_VDestroy_Serial(observables);\n" + ." N_VDestroy_Serial(ratelaws); \n" + ." N_VDestroy_Serial(species); \n" + ." CVodeFree(&cvode_mem); \n" + ." result->status = 1; \n" + ." return result; \n" + ." } "; + + # Index parameters associated with Constants, ConstantExpressions and Observables + ($err) = $plist->indexParams(); + if ($err) { return $err }; + + # and retrieve a string of expression definitions + my $n_parameters = $plist->countType( 'Constant' ); + my $n_expressions = $plist->countType( 'ConstantExpression' ) + $n_parameters; + (my $calc_expressions_string, $err) = $plist->getCVodeExpressionDefs(); + if ($err) { return $err }; + + # generate CVode references for species + # (Do this now, because we need references to CVode species for Observable definitions and Rxn Rates) + my $n_species = scalar @{$model->SpeciesList->Array}; + + # generate species string + my $species_string = ""; + foreach my $spec ( @{$model->SpeciesList->Array} ) + { + $species_string .= $spec->SpeciesGraph->toString() . "/"; + } + + # retrieve a string of observable definitions + my $n_observables = scalar @{$model->Observables}; + my $calc_observables_string; + ($calc_observables_string, $err) = $plist->getCVodeObservableDefs(); + if ($err) { return $err }; + + # generate observables string + my $observables_string = ""; + foreach my $obs ( @{$model->Observables} ) + { + $observables_string .= $obs->Name . "/"; + } + + # Construct user-defined functions + my $user_fcn_declarations = ''; + my $user_fcn_definitions = ''; + foreach my $param ( @{ $model->ParamList->Array } ) + { + if ( $param->Type eq 'Function' ) + { + # get reference to the actual Function + my $fcn = $param->Ref; + + # don't write function if it depends on a local observable evaluation (this is useless + # since CVode can't do local evaluations) + next if ( $fcn->checkLocalDependency($plist) ); + + # get function declaration, add it to the user_fcn_declarations string + $user_fcn_declarations .= $fcn->toCVodeString( $plist, {fcn_mode=>'declare',indent=>''} ); + + # get function definition + my $fcn_defn = $fcn->toCVodeString( $plist, {fcn_mode=>'define', indent=>''} ); + + # add definition to the user_fcn_definitions string + $user_fcn_definitions .= $fcn_defn . "\n"; + } + } + + # index reactions + ($err) = $model->RxnList->updateIndex( $plist ); + if ($err) { return $err }; + + # retrieve a string of reaction rate definitions + my $n_reactions = scalar @{$model->RxnList->Array}; + my $calc_ratelaws_string; + ($calc_ratelaws_string, $err) = $model->RxnList->getCVodeRateDefs( $plist ); + if ($err) { return $err }; + + + # get stoichiometry matrix (sparse encoding in a hashmap) + my $stoich_hash = {}; + ($err) = $model->RxnList->calcStoichMatrix( $stoich_hash ); + + # retrieve a string of species deriv definitions + my $calc_derivs_string; + ($calc_derivs_string, $err) = $model->SpeciesList->toCVodeString( $model->RxnList, $stoich_hash, $plist ); + if ($err) { return $err }; + + # open C and begin printing... + open( Cpyfile, ">$cpy_path" ) or die "Couldn't open $cpy_path: $!\n"; + print Cpyfile <<"EOF"; +/* +** ${cpy_filename} +** +** Cvode-C for Python Ctypes implementation of BioNetGen model '$model_name'. +** +** Code Adapted from templates provided by Mathworks and Sundials. +** +** Requires the CVODE libraries: sundials_cvode and sundials_nvecserial. +** https://computation.llnl.gov/casc/sundials/main.html +** +**----------------------------------------------------------------------------- +** +** Compilation notes: +** +** include the model in your C++ file with +** +** #include <$model_name.h> +** +** and compile with +** +** gcc -fPIC -I/path/to/cvode_lib/include/ -c '$model_name'.c +** gcc '$model_name'.o --shared -fPIC -L/path/to/cvode_lib/lib/ -lsundials_cvode -lsundials_nvecserial -o '$model_name'.so +** +** note1: if cvode is in your library path, you can omit path specifications. +** +**----------------------------------------------------------------------------- +** +** Usage in Python : +** +** TODO +*/ + +/* Library headers */ +#include +#include +#include +#include +#include /* prototypes for CVODE */ +#include /* serial N_Vector */ +#include /* prototype for CVDense */ +#include /* prototype for CVSpgmr */ + +/* Problem Dimensions */ +#define __N_PARAMETERS__ $n_parameters +#define __N_EXPRESSIONS__ $n_expressions +#define __N_OBSERVABLES__ $n_observables +#define __N_RATELAWS__ $n_reactions +#define __N_SPECIES__ $n_species + +// return struct +typedef struct result { + int status; + int n_observables; + int n_species; + int n_tpts; + int obs_name_len; + int spcs_name_len; + double *observables; + double *species; + char *obs_names; + char *spcs_names; +} RESULT; + + +/* core function declarations */ +RESULT *simulate ( int num_tpts, double *timepts, int num_species_init, double *species_init, int num_parameters, double *parameters ); +int check_flag ( void *flagvalue, char *funcname, int opt ); +void calc_expressions ( N_Vector expressions, double * parameters ); +void calc_observables ( N_Vector observables, N_Vector species, N_Vector expressions ); +void calc_ratelaws ( N_Vector ratelaws, N_Vector species, N_Vector expressions, N_Vector observables ); +int calc_species_deriv ( realtype time, N_Vector species, N_Vector Dspecies, void * f_data ); + +/* user-defined function declarations */ +$user_fcn_declarations + +/* user-defined function definitions */ +$user_fcn_definitions + +/* Calculate expressions */ +void +calc_expressions ( N_Vector expressions, double * parameters ) +{ +$calc_expressions_string +} + +/* Calculate observables */ +void +calc_observables ( N_Vector observables, N_Vector species, N_Vector expressions ) +{ +$calc_observables_string +} + +/* Calculate ratelaws */ +void +calc_ratelaws ( N_Vector ratelaws, N_Vector species, N_Vector expressions, N_Vector observables ) +{ +$calc_ratelaws_string +} + + +/* Calculate species derivatives */ +int +calc_species_deriv ( realtype time, N_Vector species, N_Vector Dspecies, void * f_data ) +{ + int return_val; + N_Vector * temp_data; + + N_Vector expressions; + N_Vector observables; + N_Vector ratelaws; + + /* cast temp_data */ + temp_data = (N_Vector*)f_data; + + /* sget ratelaws Vector */ + expressions = temp_data[0]; + observables = temp_data[1]; + ratelaws = temp_data[2]; + + /* calculate observables */ + calc_observables( observables, species, expressions ); + + /* calculate ratelaws */ + calc_ratelaws( ratelaws, species, expressions, observables ); + + /* calculate derivatives */ +$calc_derivs_string + + return(0); +} + +/* Check function return value... + * opt == 0 means SUNDIALS function allocates memory so check if + * returned NULL pointer + * opt == 1 means SUNDIALS function returns a flag so check if + * flag >= 0 + * opt == 2 means function allocates memory so check if returned + * NULL pointer + */ +int check_flag(void *flagvalue, char *funcname, int opt) +{ + int *errflag; + + /* Check if SUNDIALS function returned NULL pointer - no memory allocated */ + if (opt == 0 && flagvalue == NULL) + { + printf( "\\nSUNDIALS_ERROR: %s() failed - returned NULL pointer\\n", funcname ); + return(1); + } + + /* Check if flag < 0 */ + else if (opt == 1) + { + errflag = (int *) flagvalue; + if (*errflag < 0) + { + printf( "\\nSUNDIALS_ERROR: %s() failed with flag = %d\\n", funcname, *errflag ); + return(1); + } + } + + /* Check if function returned NULL pointer - no memory allocated */ + else if (opt == 2 && flagvalue == NULL) + { + printf( "\\nMEMORY_ERROR: %s() failed - returned NULL pointer\\n", funcname ); + return(1); + } + + return(0); +} + +/* +** ======================== +** main simulate command +** ======================== +*/ +// we have an input array of (a) time points, (b) species init and (c) parameters +// we have an output array of (a) status, (b) species and (c) observables we need to edit +// plhs = inputs, prhs = outputs, nrhs/nrhs are gone +RESULT *simulate( int num_tpts, double *timepoints, int num_species_init, double *species_init, int num_parameters, double *parameters ) +{ + /* variables */ + size_t i; + size_t j; + + /* intermediate data vectors */ + N_Vector expressions; + N_Vector observables; + N_Vector ratelaws; + + /* array to hold pointers to data vectors */ + N_Vector temp_data[3]; + + /* CVODE specific variables */ + realtype reltol; + realtype abstol; + realtype time; + N_Vector species; + void * cvode_mem; + int flag; + + /* make sure timepoints has correct dimensions */ + if ( num_tpts <= 1 ) + { printf("TIMEPOINTS must be a column vector with 2 or more elements."); } + + /* make sure species_init has correct dimensions */ + if ( num_species_init != __N_SPECIES__ ) + { printf("SPECIES_INIT must be a row vector with $n_species elements."); } + + /* make sure params has correct dimensions */ + if ( num_parameters != __N_PARAMETERS__ ) + { printf("PARAMS must be a column vector with $n_parameters elements."); } + + // set output result object + RESULT res_obj; + RESULT *result; + result = malloc(sizeof(RESULT)); + res_obj.n_observables = __N_OBSERVABLES__; + res_obj.n_species = __N_SPECIES__; + res_obj.n_tpts = num_tpts; + double *res_species_ptr; + double *res_observables_ptr; + res_species_ptr = malloc(num_tpts*__N_SPECIES__*sizeof(double)); + res_observables_ptr = malloc(num_tpts*__N_OBSERVABLES__*sizeof(double)); + res_obj.species = res_species_ptr; + res_obj.observables = res_observables_ptr; + res_obj.status = 0; + res_obj.obs_name_len = 0; + res_obj.spcs_name_len = 0; + // store the observable and species names + char onames[] = "$observables_string"; + char snames[] = "$species_string"; + char *ptr_obs_names = strdup(onames); + char *ptr_spcs_names = strdup(snames); + size_t olen = sizeof(onames); + size_t slen = sizeof(snames); + res_obj.obs_names = ptr_obs_names; + res_obj.spcs_names = ptr_spcs_names; + res_obj.obs_name_len = olen; + res_obj.spcs_name_len = slen; + + *result = res_obj; + + /* initialize intermediate data vectors */ + expressions = NULL; + expressions = N_VNew_Serial(__N_EXPRESSIONS__); + if (check_flag((void *)expressions, "N_VNew_Serial", 0)) + { + result->status = 1; + return result; + } + + observables = NULL; + observables = N_VNew_Serial(__N_OBSERVABLES__); + if (check_flag((void *)observables, "N_VNew_Serial", 0)) + { + N_VDestroy_Serial(expressions); + result->status = 1; + return result; + } + + ratelaws = NULL; + ratelaws = N_VNew_Serial(__N_RATELAWS__); + if (check_flag((void *)ratelaws, "N_VNew_Serial", 0)) + { + N_VDestroy_Serial(expressions); + N_VDestroy_Serial(observables); + result->status = 1; + return result; + } + + /* set up pointers to intermediate data vectors */ + temp_data[0] = expressions; + temp_data[1] = observables; + temp_data[2] = ratelaws; + + /* calculate expressions (expressions are constant, so only do this once!) */ + calc_expressions( expressions, parameters ); + + /* SOLVE model equations! */ + species = NULL; + cvode_mem = NULL; + + /* Set the scalar relative tolerance */ + reltol = $cvode_reltol; + abstol = $cvode_abstol; + + /* Create serial vector for Species */ + species = N_VNew_Serial(__N_SPECIES__); + if (check_flag((void *)species, "N_VNew_Serial", 0)) + { + N_VDestroy_Serial(expressions); + N_VDestroy_Serial(observables); + N_VDestroy_Serial(ratelaws); + result->status = 1; + return result; + } + for ( i = 0; i < __N_SPECIES__; i++ ) + { NV_Ith_S(species,i) = species_init[i]; } + + /* write initial species populations into species_out */ + for ( i = 0; i < __N_SPECIES__; i++ ) + { res_species_ptr[i*num_tpts] = species_init[i]; } + + /* write initial observables populations into species_out */ + calc_observables( observables, species, expressions ); + for ( i = 0; i < __N_OBSERVABLES__; i++ ) + { res_observables_ptr[i*num_tpts] = NV_Ith_S(observables,i); } + + /* Call CVodeCreate to create the solver memory: + * CV_ADAMS or CV_BDF is the linear multistep method + * CV_FUNCTIONAL or CV_NEWTON is the nonlinear solver iteration + * A pointer to the integrator problem memory is returned and stored in cvode_mem. + */ + cvode_mem = CVodeCreate($cvode_linear_multistep, $cvode_nonlinear_solver); + if (check_flag((void *)cvode_mem, "CVodeCreate", 0)) + $cvode_cleanup_memory + + + + /* Call CVodeInit to initialize the integrator memory: + * cvode_mem is the pointer to the integrator memory returned by CVodeCreate + * rhs_func is the user's right hand side function in y'=f(t,y) + * T0 is the initial time + * y is the initial dependent variable vector + */ + flag = CVodeInit(cvode_mem, calc_species_deriv, timepoints[0], species); + if (check_flag(&flag, "CVodeInit", 1)) + $cvode_cleanup_memory + + /* Set scalar relative and absolute tolerances */ + flag = CVodeSStolerances(cvode_mem, reltol, abstol); + if (check_flag(&flag, "CVodeSStolerances", 1)) + $cvode_cleanup_memory + + /* pass params to rhs_func */ + flag = CVodeSetUserData(cvode_mem, &temp_data); + if (check_flag(&flag, "CVodeSetFdata", 1)) + $cvode_cleanup_memory + + /* select linear solver */ + $cvode_linear_solver + $cvode_cleanup_memory + + flag = CVodeSetMaxNumSteps(cvode_mem, $cvode_max_num_steps); + if (check_flag(&flag, "CVodeSetMaxNumSteps", 1)) + $cvode_cleanup_memory + + flag = CVodeSetMaxErrTestFails(cvode_mem, $cvode_max_err_test_fails); + if (check_flag(&flag, "CVodeSetMaxErrTestFails", 1)) + $cvode_cleanup_memory + + flag = CVodeSetMaxConvFails(cvode_mem, $cvode_max_conv_fails); + if (check_flag(&flag, "CVodeSetMaxConvFails", 1)) + $cvode_cleanup_memory + + flag = CVodeSetMaxStep(cvode_mem, $cvode_max_step); + if (check_flag(&flag, "CVodeSetMaxStep", 1)) + $cvode_cleanup_memory + + /* integrate to each timepoint */ + for ( i=1; i < num_tpts; i++ ) + { + flag = CVode(cvode_mem, timepoints[i], species, &time, CV_NORMAL); + if (check_flag(&flag, "CVode", 1)) + { + N_VDestroy_Serial(expressions); + N_VDestroy_Serial(observables); + N_VDestroy_Serial(ratelaws); + N_VDestroy_Serial(species); + CVodeFree(&cvode_mem); + result->status = 1; + return result; + } + + /* copy species output from nvector to matlab array */ + for ( j = 0; j < __N_SPECIES__; j++ ) + { res_species_ptr[j*num_tpts + i] = NV_Ith_S(species,j); } + + /* copy observables output from nvector to matlab array */ + calc_observables( observables, species, expressions ); + for ( j = 0; j < __N_OBSERVABLES__; j++ ) + { res_observables_ptr[j*num_tpts + i] = NV_Ith_S(observables,j); } + } + + /* Free vectors */ + N_VDestroy_Serial(expressions); + N_VDestroy_Serial(observables); + N_VDestroy_Serial(ratelaws); + N_VDestroy_Serial(species); + + /* Free integrator memory */ + CVodeFree(&cvode_mem); + + return result; +} + +void free_result(RESULT *r) { + free(r->obs_names); + free(r->spcs_names); + free(r->observables); + free(r->species); + free(r); +} +EOF + close(Cpyfile); + + + + # open Mexfile and begin printing... + + print "Wrote Cpyfile $cpy_path.\n"; + return (); +} + +### +### +### + + + + +sub writeMfile_QueryNames +{ + my $model = shift; + my $plist = $model->ParamList; + my $slist = $model->SpeciesList; + my $err; + + my $mscript_param_names; + my $mscript_param_values; + ($mscript_param_names, $mscript_param_values, $err) = $plist->getMatlabConstantNames(); + if ($err) { return ($err) }; + + my $mscript_observable_names; + ($mscript_observable_names, $err) = $plist->getMatlabObservableNames(); + if ($err) { return ($err) }; + + my $mscript_species_names; + ($mscript_species_names, $err) = $slist->getMatlabSpeciesNamesOnly(); + if ($err) { return ($err) }; + + my $q_mscript = 'QueryNames.m'; + + open(Q_Mscript,">$q_mscript"); + print Q_Mscript <<"EOF"; +function [ param_labels, param_defaults, obs_labels, species_labels] = QueryNames( inputlist ) +% % Loads all the parameter labels, parameter defaults, observable labels and species labels in the model +% % If generate_network() was executed, then the nanmes of all species are passed +% % If generate_network() was not executed, then the names of the seed speceis are passed + + param_labels = { $mscript_param_names }; + param_defaults = [ $mscript_param_values ]; + obs_labels = { $mscript_observable_names }; + species_labels = { $mscript_species_names }; +end + +EOF + close Q_Mscript; + print "Wrote M-file script $q_mscript.\n"; + return (); + +} + + + +### +### +### + + + +sub writeMfile_ParametersObservables +{ + # John Sekar created this subroutine + my $model = shift; + my $params = (@_) ? shift : {}; + + my $err; + + #Get ref to parameter list + my $plist = $model->ParamList; + + #Names of M-file + my $par_mscript = 'ParameterList.m'; + my $obs_mscript = 'ObservableList.m'; + + #Getting param names and observable names + my $mscript_param_names; + my $mscript_param_values; + ($mscript_param_names, $mscript_param_values, $err) = $plist->getMatlabConstantNames(); + if ($err) { return ($err) }; + $mscript_param_names =~ s/[\\]//g; + + my $mscript_observable_names; + ($mscript_observable_names, $err) = $plist->getMatlabObservableNames(); + if ($err) { return ($err) }; + $mscript_observable_names =~ s/[\\]//g; + + + #Writing parameter list script + open( Par_Mscript, ">$par_mscript" ) || die "Couldn't open $par_mscript: $!\n"; + print Par_Mscript <<"EOF"; +function [outputlist,defaultvals ] = ParameterList( inputlist ) +% Used to manipulate and access parameter names +% If inputlist is empty, the entire list of labels is given as output +% If inputlist is a vector of indices, output is a cell array of parameter +% names corresponding to those indices, returns default error if not found +% If inputlist is a cell array of names, output is a vector of indices +% corresponding to those parameter names, returns zero if not found + param_labels = { $mscript_param_names }; + param_defaults = [ $mscript_param_values ]; + + param_num = max(size(param_labels)); + + if nargin < 1 + outputlist = param_labels; + defaultvals = param_defaults; + return; + end + + defaultvals = zeros(size(inputlist)); + + if(isnumeric(inputlist)) + outputlist = cell(size(inputlist)); + + + for i=1:1:max(size(inputlist)) + outputlist{i} = param_labels{inputlist(i)}; + defaultvals(i) = param_defaults(inputlist(i)); + end + end + + if(iscellstr(inputlist)) + outputlist = zeros(size(inputlist)); + for i=1:1:max(size(inputlist)) + compare = strcmp(inputlist{i},param_labels); + if(sum(compare)>0) + outputlist(i) = find(compare,1); + if(outputlist(i)) + defaultvals(i) = param_defaults(outputlist(i)); + end + end + + end + end +end +EOF + close Par_Mscript; + print "Wrote M-file script $par_mscript.\n"; + + #Writing observable list script + open( Obs_Mscript, ">$obs_mscript" ) || die "Couldn't open $obs_mscript: $!\n"; + print Obs_Mscript <<"EOF"; +function [outputlist ] = ObservableList( inputlist ) +% Used to manipulate and access observable names +% If inputlist is empty, the entire list of labels is given as output +% If inputlist is a vector of indices, output is a cell array of observable +% names corresponding to those indices, returns default error if not found +% If inputlist is a cell array of names, output is a vector of indices +% corresponding to those observable names, returns zero if not found + obs_labels = { $mscript_observable_names }; + obs_num = max(size(obs_labels)); + + if nargin < 1 + outputlist = obs_labels; + return; + end + + if(isnumeric(inputlist)) + outputlist = cell(size(inputlist)); + for i=1:1:max(size(inputlist)) + outputlist{i} = obs_labels{inputlist(i)}; + end + end + + if(iscellstr(inputlist)) + outputlist = zeros(size(inputlist)); + for i=1:1:max(size(inputlist)) + compare = strcmp(inputlist{i},obs_labels); + if(sum(compare)>0) + outputlist(i) = find(compare,1); + else + outputlist(i) = 0; + end + end +end +EOF + close Obs_Mscript; + print "Wrote M-file script $obs_mscript.\n"; + return (); +} + + + +### +### +### + +sub writeLaTeXfile +{ + my $model = shift @_; + my $params = (@_) ? shift @_ : {}; + $model->writeLatex( $params ); + return; +} + +sub writeLatex +{ + my $model = shift @_; + my $params = @_ ? shift @_ : {}; + + return '' if $BNGModel::NO_EXEC; + + unless ( $model->RxnList ) + { return "writeLatex(): No reactions in current model--nothing to do."; } + + # parameter list + my $plist = $model->ParamList; + + # model name + my $model_name = $model->Name; + + # Strip prefixed path + my $prefix = defined $params->{prefix} ? $model->getOutputPrefix( $params->{prefix} ) : $model->getOutputPrefix(); + my $suffix = ( defined $params->{suffix} ) ? $params->{suffix} : undef; + unless ( $suffix eq '' ) { $prefix .= "_${suffix}"; } + + # latex filename + my $file = "${prefix}.tex"; + + # open file + my $Lfile; + open( $Lfile, ">$file" ) or die "Couldn't open $file: $!\n"; + + my $version = BNGversion(); + print$Lfile "% Latex formatted differential equations for model $prefix created by BioNetGen $version\n"; + + # Document Header + print $Lfile <<'EOF'; +\documentclass{article} +\begin{document} +EOF + + # Dimensions + my $Nspecies = scalar @{$model->SpeciesList->Array}; + my $Nreactions = scalar @{$model->RxnList->Array}; + print $Lfile "\\section{Model Summary}\n"; + printf $Lfile "The model has %d species and %d reactions.\n", $Nspecies, $Nreactions; + print $Lfile "\n"; + + + # Stoichiometry matrix + my %S = (); + my @fluxes = (); + my $irxn = 1; + foreach my $rxn ( @{$model->RxnList->Array} ) + { + # Each reactant contributes a -1 + foreach my $r ( @{$rxn->Reactants} ) + { + --$S{ $r->Index }{$irxn}; + } + + # Each product contributes a +1 + foreach my $p ( @{$rxn->Products} ) + { + ++$S{ $p->Index }{$irxn}; + } + my ($flux, $err) = $rxn->RateLaw->toLatexString( $rxn->Reactants, $rxn->StatFactor, + $model->ParamList ); + if ($err) { return $err; } + push @fluxes, $flux; + ++$irxn; + } + + print $Lfile "\\section{Differential Equations}\n"; + print $Lfile "\\begin{eqnarray*}\n"; + foreach my $ispec ( sort {$a <=> $b} keys %S ) + { + printf $Lfile "\\dot{x_{%d}}&=& ", $ispec; + my $nrxn = 1; + foreach my $irxn ( sort { $a <=> $b } keys %{ $S{$ispec} } ) + { + my $mod; + my $s = $S{$ispec}{$irxn}; + if ( $s == 1 ) { + $mod = "+"; + } + elsif ( $s == -1 ) { + $mod = "-"; + } + elsif ( $s > 0 ) { + $mod = "+$s"; + } + else { + $mod = "+($s)"; + } + if ( ($nrxn % 5) == 0 ) { print $Lfile "\\\\ &&"; } + if ($s) + { + printf $Lfile " %s %s", $mod, $fluxes[ $irxn - 1 ]; + ++$nrxn; + } + } + + if ( $nrxn == 1 ) { print $Lfile "0"; } + print $Lfile "\n\\\\\n"; + } + print $Lfile "\\end{eqnarray*}\n"; + print $Lfile "\n"; + + # Document Footer + print $Lfile <<'EOF'; +\end{document} +EOF + close $Lfile; + print "Wrote Latex equations to $file.\n"; + return; +} + +sub writeMfile_all +{ + +# Author: John Sekar +# Writes 3 files +# initSpecies_$name.m which holds the species initialization relations +# $name.m which is the model simulator (same as writeMfile) +# bngModel_$name.m which is a class which inherits bngModel from the MatLab toolbox + my $model = shift @_; + my $params = @_ ? shift @_ : {}; + + # a place to hold errors + my $err; + + # nothing to do if NO_EXEC is true + return '' if $BNGModel::NO_EXEC; + + # nothing to do if there are no reactions + unless ( $model->RxnList ) + { + return ( "writeMfile() has nothing to do: no reactions in current model.\n" + ." Did you remember to call generate_network() before attempting to\n" + ." write network output?"); + } + + # get reference to parameter list + my $plist = $model->ParamList; + + + # get model name + my $model_name = $model->Name; + + # Build output file name + # ..use prefix if defined, otherwise use model name + my $prefix = defined $params->{prefix} ? $model->getOutputPrefix( $params->{prefix} ) : $model->getOutputPrefix(); + # ..add suffix, if any + my $suffix = ( defined $params->{suffix} ) ? $params->{suffix} : undef; + if ( $suffix ) + { $prefix .= "_${suffix}"; } + + # split prefix into volume, path and filebase + my ($vol, $path, $filebase) = File::Spec->splitpath($prefix); + + # define m-script file name + my $mscript_filebase = "${filebase}"; + my $mscript_filename = "${mscript_filebase}.m"; + my $mscript_path = File::Spec->catpath($vol,$path,$mscript_filename); + my $mscript_filebase_caps = uc $mscript_filebase; + + # configure options (see Matlab documentation of functions ODESET and ODE15S) + my $odeset_abstol = 1e-4; + if ( exists $params->{'atol'} ) + { $odeset_abstol = $params->{'atol'}; } + + my $odeset_reltol = 1e-8; + if ( exists $params->{'rtol'} ) + { $odeset_reltol = $params->{'rtol'}; } + + my $odeset_stats = 'off'; + if ( exists $params->{'stats'} ) + { $odeset_stats = $params->{'stats'}; } + + my $odeset_bdf = 'off'; + if ( exists $params->{'bdf'} ) + { $odeset_bdf = $params->{'bdf'}; } + + my $odeset_maxorder = 5; + if ( exists $params->{'maxOrder'} ) + { $odeset_maxorder = $params->{'maxOrder'}; } + + # time options for mscript + my $t_start = 0; + if ( exists $params->{'t_start'} ) + { $t_start = $params->{'t_start'}; } + + my $t_end = 10; + if ( exists $params->{'t_end'} ) + { $t_end = $params->{'t_end'}; } + + my $n_steps = 20; + if ( exists $params->{'n_steps'} ) + { $n_steps = $params->{'n_steps'}; } + + # configure time step dependent options + my $odeset_maxstep = undef; + if ( exists $params->{'max_step'} ) + { $odeset_maxstep = $params->{'max_step'}; } + + # construct ODESET function call + my $mscript_call_odeset; + if ( defined $odeset_maxstep ) + { + $mscript_call_odeset = "opts = odeset( 'RelTol', $odeset_reltol, ...\n" + ." 'AbsTol', $odeset_abstol, ...\n" + ." 'Stats', '$odeset_stats', ...\n" + ." 'BDF', '$odeset_bdf', ...\n" + ." 'MaxOrder', $odeset_maxorder, ...\n" + ." 'MaxStep', $odeset_maxstep );\n"; + } + else + { + $mscript_call_odeset = "opts = odeset( 'RelTol', $odeset_reltol, ...\n" + ." 'AbsTol', $odeset_abstol, ...\n" + ." 'Stats', '$odeset_stats', ...\n" + ." 'BDF', '$odeset_bdf', ...\n" + ." 'MaxOrder', $odeset_maxorder );\n"; + } + + # Index parameters associated with Constants, ConstantExpressions and Observables + ($err) = $plist->indexParams(); + if ($err) { return $err }; + + # and retrieve a string of expression definitions + my $n_parameters = $plist->countType( 'Constant' ); + my $n_expressions = $plist->countType( 'ConstantExpression' ) + $n_parameters; + (my $calc_expressions_string, $err) = $plist->getMatlabExpressionDefs(); + if ($err) { return $err }; + + # get list of parameter names and defintions for matlab + my $mscript_param_names; + my $mscript_param_values; + ($mscript_param_names, $mscript_param_values, $err) = $plist->getMatlabConstantNames(); + if ($err) { return $err }; + + # get number of species + my $n_species = scalar @{$model->SpeciesList->Array}; + + # retrieve a string of observable definitions + my $n_observables = scalar @{$model->Observables}; + my $calc_observables_string; + ($calc_observables_string, $err) = $plist->getMatlabObservableDefs(); + if ($err) { return $err }; + + # get list of observable names for matlab + my $mscript_observable_names; + ($mscript_observable_names, $err) = $plist->getMatlabObservableNames(); + if ($err) { return $err }; + + # Construct user-defined functions + my $user_fcn_declarations = ''; + my $user_fcn_definitions = ''; + foreach my $param ( @{ $model->ParamList->Array } ) + { + if ( $param->Type eq 'Function' ) + { + # get reference to the actual Function + my $fcn = $param->Ref; + + # don't write function if it depends on a local observable evaluation (this is useless + # since CVode can't do local evaluations) + next if ( $fcn->checkLocalDependency($plist) ); + + # get function definition + my $fcn_defn = $fcn->toMatlabString( $plist, {fcn_mode=>'define', indent=>''} ); + + # add definition to the user_fcn_definitions string + $user_fcn_definitions .= $fcn_defn . "\n"; + } + } + + # index reactions + ($err) = $model->RxnList->updateIndex( $plist ); + if ($err) { return $err }; + + # retrieve a string of reaction rate definitions + my $n_reactions = scalar @{$model->RxnList->Array}; + my $calc_ratelaws_string; + ($calc_ratelaws_string, $err) = $model->RxnList->getMatlabRateDefs( $plist ); + if ($err) { return $err }; + + + # get stoichiometry matrix (sparse encoding in a hashmap) + my $stoich_hash = {}; + ($err) = $model->RxnList->calcStoichMatrix( $stoich_hash ); + + # retrieve a string of species deriv definitions + my $calc_derivs_string; + ($calc_derivs_string, $err) = $model->SpeciesList->toMatlabString( $model->RxnList, $stoich_hash, $plist ); + if ($err) { return $err }; + + + # get list of species names and initial value expressions for matlab + my $mscript_species_names; + my $mscript_species_init; + ($mscript_species_names, $mscript_species_init, $err) = $model->SpeciesList->getMatlabSpeciesNames( $model ); + if ($err) { return $err }; + + + ## Set up MATLAB Plot + # fontsizes + my $title_fontsize = 14; + my $axislabel_fontsize = 12; + my $legend_fontsize = 10; + + # generate code snippets for plotting observables or species + my $mscript_plot_labels; + my $mscript_make_plot; + + # get ylabel (either Number of Concentration) + my $ylabel; + if ( $model->SubstanceUnits eq 'Number' ) + { $ylabel = 'number'; } + elsif ( $model->SubstanceUnits eq 'Concentration' ) + { $ylabel = 'concentration'; } + else + { $ylabel = 'number or concentration'; } + + + if ( @{$model->Observables} ) + { # plot observables + $mscript_plot_labels = " observable_labels = { $mscript_observable_names };\n"; + + $mscript_make_plot = " plot(timepoints,observables_out);\n" + ." title('${mscript_filebase} observables','fontSize',${title_fontsize},'Interpreter','none');\n" + ." axis([${t_start} timepoints(end) 0 inf]);\n" + ." legend(observable_labels,'fontSize',${legend_fontsize},'Interpreter','none');\n" + ." xlabel('time','fontSize',${axislabel_fontsize},'Interpreter','none');\n" + ." ylabel('${ylabel}','fontSize',${axislabel_fontsize},'Interpreter','none');\n"; + + } + else + { # plot species + $mscript_plot_labels = " species_labels = { $mscript_species_names };\n"; + + $mscript_make_plot = " plot(timepoints,species_out);\n" + ." title('${mscript_filebase} species','fontSize',${title_fontsize},'Interpreter','none');\n" + ." axis([${t_start} timepoints(end) 0 inf]);\n" + ." legend(species_labels,'fontSize',${legend_fontsize},'Interpreter','none');\n" + ." xlabel('time','fontSize',${axislabel_fontsize},'Interpreter','none');\n" + ." ylabel('${ylabel}','fontSize',${axislabel_fontsize},'Interpreter','none');\n"; + } + + + + # open Mfile and begin printing... + open( Mscript, ">$mscript_path" ) || die "Couldn't open $mscript_path: $!\n"; + print Mscript <<"EOF"; +function [err, timepoints, species_out, observables_out ] = ${mscript_filebase}( timepoints, species_init, parameters, suppress_plot ) +%${mscript_filebase_caps} Integrate reaction network and plot observables. +% Integrates the reaction network corresponding to the BioNetGen model +% '${model_name}' and then (optionally) plots the observable trajectories, +% or species trajectories if no observables are defined. Trajectories are +% generated using either default or user-defined parameters and initial +% species values. Integration is performed by the MATLAB stiff solver +% 'ode15s'. ${mscript_filebase_caps} returns an error value, a vector of timepoints, +% species trajectories, and observable trajectories. +% +% [err, timepoints, species_out, observables_out] +% = $mscript_filebase( timepoints, species_init, parameters, suppress_plot ) +% +% INPUTS: +% ------- +% species_init : row vector of $n_species initial species populations. +% timepoints : column vector of time points returned by integrator. +% parameters : row vector of $n_parameters model parameters. +% suppress_plot : 0 if a plot is desired (default), 1 if plot is suppressed. +% +% Note: to specify default value for an input argument, pass the empty array. +% +% OUTPUTS: +% -------- +% err : 0 if the integrator exits without error, non-zero otherwise. +% timepoints : a row vector of timepoints returned by the integrator. +% species_out : array of species population trajectories +% (columns correspond to species, rows correspond to time). +% observables_out : array of observable trajectories +% (columns correspond to observables, rows correspond to time). +% +% QUESTIONS about the BNG Mfile generator? Email justinshogg\@gmail.com + + + +%% Process input arguments + +% define any missing arguments +if ( nargin < 1 ) + timepoints = []; +end + +if ( nargin < 2 ) + species_init = []; +end + +if ( nargin < 3 ) + parameters = []; +end + +if ( nargin < 4 ) + suppress_plot = 0; +end + + +% initialize outputs (to avoid error msgs if script terminates early +err = 0; +species_out = []; +observables_out = []; + + +% setup default parameters, if necessary +if ( isempty(parameters) ) + parameters = [ $mscript_param_values ]; +end +% check that parameters has proper dimensions +if ( size(parameters,1) ~= 1 || size(parameters,2) ~= $n_parameters ) + fprintf( 1, 'Error: size of parameter argument is invalid! Correct size = [1 $n_parameters].\\n' ); + err = 1; + return; +end + +% setup default initial values, if necessary +if ( isempty(species_init) ) + species_init = initialize_species( parameters ); +end +% check that species_init has proper dimensions +if ( size(species_init,1) ~= 1 || size(species_init,2) ~= $n_species ) + fprintf( 1, 'Error: size of species_init argument is invalid! Correct size = [1 $n_species].\\n' ); + err = 1; + return; +end + +% setup default timepoints, if necessary +if ( isempty(timepoints) ) + timepoints = linspace($t_start,$t_end,$n_steps+1)'; +end +% check that timepoints has proper dimensions +if ( size(timepoints,1) < 2 || size(timepoints,2) ~= 1 ) + fprintf( 1, 'Error: size of timepoints argument is invalid! Correct size = [t 1], t>1.\\n' ); + err = 1; + return; +end + +% setup default suppress_plot, if necessary +if ( isempty(suppress_plot) ) + suppress_plot = 0; +end +% check that suppress_plot has proper dimensions +if ( size(suppress_plot,1) ~= 1 || size(suppress_plot,2) ~= 1 ) + fprintf( 1, 'Error: suppress_plots argument should be a scalar!\\n' ); + err = 1; + return; +end + +% define parameter labels (this is for the user's reference!) +param_labels = { $mscript_param_names }; + + + +%% Integrate Network Model + +% calculate expressions +[expressions] = calc_expressions( parameters ); + +% set ODE integrator options +$mscript_call_odeset + +% define derivative function +rhs_fcn = @(t,y)( calc_species_deriv( t, y, expressions ) ); + +% simulate model system (stiff integrator) +try + [timepoints, species_out] = ode15s( rhs_fcn, timepoints, species_init', opts ); +catch + err = 1; + fprintf( 1, 'Error: some problem encounteredwhile integrating ODE network!\\n' ); + return; +end + +% calculate observables +observables_out = zeros( length(timepoints), $n_observables ); +for t = 1 : length(timepoints) + observables_out(t,:) = calc_observables( species_out(t,:), expressions ); +end + + +%% Plot Output, if desired + +if ( ~suppress_plot ) + + % define plot labels +$mscript_plot_labels + % construct figure +$mscript_make_plot +end + + +%~~~~~~~~~~~~~~~~~~~~~% +% END of main script! % +%~~~~~~~~~~~~~~~~~~~~~% + + +% initialize species function +function [species_init] = initialize_species( params ) + + species_init = zeros(1,$n_species); +$mscript_species_init +end + + +% user-defined functions +$user_fcn_definitions + + +% Calculate expressions +function [ expressions ] = calc_expressions ( parameters ) + + expressions = zeros(1,$n_expressions); +$calc_expressions_string +end + + + +% Calculate observables +function [ observables ] = calc_observables ( species, expressions ) + + observables = zeros(1,$n_observables); +$calc_observables_string +end + + +% Calculate ratelaws +function [ ratelaws ] = calc_ratelaws ( species, expressions, observables ) + + ratelaws = zeros(1,$n_observables); +$calc_ratelaws_string +end + +% Calculate species derivatives +function [ Dspecies ] = calc_species_deriv ( time, species, expressions ) + + % initialize derivative vector + Dspecies = zeros($n_species,1); + + % update observables + [ observables ] = calc_observables( species, expressions ); + + % update ratelaws + [ ratelaws ] = calc_ratelaws( species, expressions, observables ); + + % calculate derivatives +$calc_derivs_string +end + + +end +EOF + + close(Mscript); + print "Wrote M-file script $mscript_path.\n"; + +# define m-script file name + $mscript_filebase = "initSpecies_${filebase}"; + $mscript_filename = "${mscript_filebase}.m"; + $mscript_path = File::Spec->catpath($vol,$path,$mscript_filename); + $mscript_filebase_caps = uc $mscript_filebase; + + open( Mscript, ">$mscript_path" ) || die "Couldn't open $mscript_path: $!\n"; + print Mscript <<"EOF"; + function [species_init] = initialize_species( params ) + + species_init = zeros(1,$n_species); +$mscript_species_init +end + +EOF + + close(Mscript); + print "Wrote M-file script $mscript_path.\n"; + + $mscript_filebase = "bngModel_${filebase}"; + $mscript_filename = "${mscript_filebase}.m"; + $mscript_path = File::Spec->catpath($vol,$path,$mscript_filename); + $mscript_filebase_caps = uc $mscript_filebase; + + open( Mscript, ">$mscript_path" ) || die "Couldn't open $mscript_path: $!\n"; + print Mscript <<"EOF"; +classdef ${mscript_filebase} < bngModel + + properties + end + + methods + + function obj = ${mscript_filebase} + obj = obj\@bngModel; + + species_labels = { $mscript_species_names }; + param_labels = { $mscript_param_names }; + param_defaults = [ $mscript_param_values ] ; + obs_labels = { $mscript_observable_names }; + simulators = { \'$filebase\' }; + + obj.Param = bngParam(param_labels,param_defaults); + obj.Obs = bngObs(obs_labels); + obj.Species = bngSpecies(species_labels,\'initSpecies_${filebase}\'); + obj.simulators = simulators; + + end + + end + + +end + +EOF + + close(Mscript); + print "Wrote M-file script $mscript_path.\n"; + +return(); +} + +### +### +### + +sub visualize +{ + use Visualization::Viz; + use Visualization::VisOptParse; + + my $model = shift @_; + my $user_params = @_ ? shift @_ : {}; + + # default options + my $params = + { 'help' => 0, + 'type' => 'regulatory', + 'opts' => undef, + 'background' => 0, + 'collapse' => 0, + 'each' => 0, + 'groups' => 0, + 'textonly' => 0, + 'suffix' => '', + 'filter' => 0, + 'level' => 1, + 'mergepairs' => 0, + 'embed' => 0, + 'reset' => 1, + 'ruleNames' => 0, + 'doNotUseContextWhenGrouping' => 0, + 'removeReactantContext' => 0, + 'makeInhibitionEdges' => 0, + 'removeProcessNodes' => 0, + 'compressRuleMotifs' => 0, + 'doNotCollapseEdges' => 0, + }; + + # get user options + foreach my $par (keys %$user_params) + { + my $val = $user_params->{$par}; + #unless ( exists $params->{$par} ) + #{ return "Unrecognized option $par in call to 'visualize'"; } + + # Special handling for 'opts': + # If a single filename is passed, convert $val to an array + if ($par eq 'opts'){ + if (not ref($val)){ + $val = [$val]; + } + } + + # overwrite default option + $params->{$par} = $val; + } + + if($params->{'help'}) + { + defined $user_params->{'type'} ? Viz::display_viz_help(\%$params) : Viz::display_viz_help(); + return ''; + } + + my $err = Viz::execute_params($model, Viz::getExecParams(\%$params)); + if ($err) { return $err; } + return ''; +} + +1; diff --git a/libvcell/vcell_install/bionetgen/Perl2/BNGUtils.pm b/libvcell/vcell_install/bionetgen/Perl2/BNGUtils.pm new file mode 100644 index 0000000..367f050 --- /dev/null +++ b/libvcell/vcell_install/bionetgen/Perl2/BNGUtils.pm @@ -0,0 +1,598 @@ +package BNGUtils; +# TODO use strict; + +# Perl Modules +use FindBin; +use lib $FindBin::Bin; +use File::Spec; +use Cwd; +use List::Util ("sum"); + +use constant VERSION_FILENAME => "VERSION"; +use constant DEFAULT_VERSION => "UNKNOWN"; +use constant DEFAULT_CODENAME => ""; + + +require Exporter; +our @ISA = qw( Exporter ); +our @EXPORT = qw( BNGversion BNGcodename compareVersions isReal booleanToInt BNGroot BNGpath exit_error send_warning cpu_time average_runs create_sbml + head split_obj split_comp verify_pattern process_val_string + validate_rate_law MIN MAX SQR log10 ); + +# Jim Faeder 3/13/2005. +{ + my $BNG_VERSION; + my $BNG_CODENAME; + my $BNG_ROOT; + + # find the BNG root directory + sub BNGroot + { + unless ($BNG_ROOT) + { # Determine BNG root directory + + # Use environment variable BNGPATH, if defined and valid + if ( exists $ENV{BNGPATH} ) + { + my $bin_dir = File::Spec->catdir( ($ENV{BNGPATH}) ); + if ( -d $bin_dir ) + { $BNG_ROOT = $bin_dir; } + else + { send_warning( "While looking for BNG root: environment variable 'BNGPATH' does not point to a valid directory!" ); } + } + # Use environment variable BioNetGenRoot, if defined and valid + elsif ( exists $ENV{BioNetGenRoot} ) + { + my $bin_dir = File::Spec->catdir( ($ENV{BioNetGenRoot}) ); + if ( -d $bin_dir ) + { $BNG_ROOT = $bin_dir; } + else + { send_warning( "While looking for BNG root: environment variable 'BioNetGenRoot' does not point to a valid directory!" ); } + } + + + # Otherwise, try the same + unless ( defined $BNG_ROOT ) + { + if (-d $FindBin::RealBin) + { $BNG_ROOT = $FindBin::RealBin; } + else + { send_warning( "While looking for BNG root: could not get RealBin directory!" ); } + } + + # As last resort, try current working directory + unless ( defined $BNG_ROOT ) + { + $BNG_ROOT = Cwd::getcwd(); + send_warning( "While looking for BNG_ROOT: defaulting to current working directory!" ); + } + } + return $BNG_ROOT; + } + + sub BNGpath + { + unless ($BNG_ROOT) + { # find BNG root directory + BNGroot(); + } + return File::Spec->catdir( ($BNG_ROOT, @_) ); + } + + # extract BNG_VERSION and BNG_CODENAME from the version file located + # at BNG_ROOT/VERSION. + sub readVersionFile + { + unless ($BNG_ROOT) + { # find BNG root directory + BNGroot(); + } + + # Get BioNetGen version number + unless (defined $BNG_VERSION) + { + # read version info from VERSION file + if ( open my $fh, '<', File::Spec->catfile($BNG_ROOT, VERSION_FILENAME) ) + { + # get first line of file + my $version_string = <$fh>; + close $fh; + + # extract version number + if ($version_string =~ s/^\s*(\d+\.\d+\.\d+)\s*//) + { $BNG_VERSION = $1; } + else + { $BNG_VERSION = DEFAULT_VERSION; } + + # extract codename (if any) + if ($version_string =~ s/^(\w+)//) + { $BNG_CODENAME = $1; } + else + { $BNG_CODENAME = DEFAULT_CODENAME; } + } + else + { + $BNG_VERSION = DEFAULT_VERSION; + $BNG_CODENAME = ''; + } + } + return; + } + + # get BNG_VERSION + sub BNGversion + { + unless (defined $BNG_VERSION) + { # find BNG root directory + readVersionFile(); + } + return $BNG_VERSION; + } + + # get BNG_CODENAME + sub BNGcodename + { + unless (defined $BNG_CODENAME) + { # find BNG root directory + readVersionFile(); + } + return $BNG_CODENAME; + } + + # compare versions: returns -1 if version1 < version2, + # 1 if version1 > version2, + # 0 if version1 == version2 + sub compareVersions + { + my ($version1, $version2) = @_; + + my (@version1) = split (/\./, $version1); + my (@version2) = split (/\./, $version2); + + # compare major, minor and release numbers + while (@version1 and @version2) + { + my $comp = ( shift @version1 <=> shift @version2 ); + if ($comp) { return $comp; } + } + + # if versions are equal so far, the version with finer defintion + # is greater than the other. + # (e.g. 2.1.7 is greater than 2.1) + return ( @version1 ? 1 : (@version2 ? -1 : 0) ); + } +} + + +# Determine if a string corresponds to a float or a double +sub isReal{ + my $string=shift; + my $isdec=0; + + if ($string=~ s/^[+-]?\d+[.]?\d*//){ + $isdec=1; + } + elsif ($string=~ s/^[+-]?[.]\d+//){ + $isdec=1; + } else { + return(0); + } + if ($string eq ""){return(1);} + + if ($string=~ s/^[DEFGdefg][+-]?\d+$//){ + return(1); + } + return(0); +} + +# Determine if a string is a Boolean +sub isBoolean{ + my $string=shift; + my $isboo; + + if ($string=~/^true$/i){ + $isboo=1; + } elsif ($string=~/^false$/i){ + $isboo=1; + } else { + $isboo=0; + } + return($isboo); +} + +# Convert boolean to integer False=0 True=1 notBoolean=-1 +sub booleanToInt{ + my $string=shift; + my $intval; + + if ($string=~/^true$/i){ + $intval=1; + } + elsif ($string=~/^false$/i){ + $intval=0; + } + # Boolean that is not a assigned a value is True by default + elsif ($string eq ""){ + $intval=1; + } + else { + $intval=-1; + } + return($intval); +} + +##--------------------------------------------------------------------------- +# Check that a pattern referring to species objects is valid. + +sub verify_pattern{ + my $pattern= shift; + my $is_spec= shift; + my $mol_ncomp= shift; + + $patt=$pattern; + # remove valid termination characters + $patt=~s/\.\*$//; + $patt=~s/\*$//; + + # split pattern into molecules and check that each is valid + my @molecules= split('\.',$patt); + for my $mol (@molecules){ + my ($head, @components)= split_obj($mol); + if ($head eq $mol){ + if ($#molecules>0){ + return(1, "Single state species $head may not appear in a complex.") + } + elsif (!defined($$is_spec{$mol})){ + return(0, "Species not declared: $pattern"); + } + } else { + # Check that number of components matches species declaration + if (!defined($$mol_ncomp{$head})){ + return(1, "Molecule $head not defined."); + } elsif ($$mol_ncomp{$head}!= $#components){ + return(1, "Number of components for molecule $head doesn't match species declaration."); + } + + # Check that each component is valid + for my $comp (@components){ + if ($comp=~/[^0-9\*]/){ + return(1, "Invalid component state $comp: May only use integers or wildcard.",$entry); + } +# if ($comp=~/[^A-Za-z0-9_\-\*]/){ +# return(1, "Invalid component state $comp in pattern $pattern: May only use alphanumeric characters, '-','_', or '*'."); +# } + } + } + } + + if ($#molecules<0){ + return(1, "No molecules specified in matching string\n"); + } + return(0,""); +} + +##--------------------------------------------------------------------------- +# Handle a value that is either a number, a parameter name, or a +# product of a number and a parameter name. + +sub process_val_string{ + my $val_string= shift; + my $entry= shift; + my $parameters= shift; + + my ($fac,$val, $value); + + $value=$val_string; + if ($value=~/(\S+)[*](\S+)/){ + $fac= $1; + $val=$2; + } else { + $fac= 1; + $val=$value; + } + + # Make sure val is valid parameter if it is not a number. + # NOTE: The checking here would be much easier with a perl routine + # isnum(string) (which is part of Acme::Utils) that returns true if the + # string is a number (in the C/Fortran sense). I didn't use this routine + # because it requires installation of additional perl modules, which might + # be beyond the capabilities of our target user. + if ($val=~/^[a-zA-Z]/){ + # Determine if parameters are allowed + ($parameters) || exit_error("Parameter not allowed for value.",$entry); + # Make sure parameter is valid + defined($$parameters{$val}) || exit_error("Parameter $val is not defined.",$entry); + # Make sure value is non-negative + if ($$parameters{$val}{val}<0){exit_error("Parameter value must be non-negative.",$entry);} + $value= $fac*$$parameters{$val}{val}; + } else { + # Substitute numerical value + $value= $fac*$val; + # Make sure value is non-negative + if ($value<0){&exit_error("Parameter value must be non-negative",$entry);} + } + +# print "fac:$fac val:$val value:$value\n"; + return($value); +} + + +# Send error message to STDERR and exit. +sub exit_error +{ + my @msgs = @_; + print STDERR "ABORT: "; + foreach my $msg (@msgs) + { + print STDERR $msg, "\n"; + } + exit(1); +} + + +# Send error message to STDERR, but do not exit. +sub send_error +{ + my @msgs = @_; + print STDERR "ERROR: "; + foreach my $msg (@msgs) + { print STDERR $msg, "\n"; } + return 0; +} + + +# send warning to STDOUT +sub send_warning +{ + my @msgs = @_; + print STDOUT "WARNING: "; + foreach my $msg (@msgs) + { print STDOUT $msg,"\n"; } + # Could have $STRICT flag to force exit + return 0; +} + + +# send error message with line number +sub line_error +{ + my ($msg, $lno) = @_; + print STDERR sprintf( "ABORT: [at line %s] %s\n", $lno, $msg ); + exit 1; +} + +# send warning message with line number +sub line_warning +{ + my ($msg, $lno) = @_; + print STDOUT sprintf( "WARNING: [at line %s] %s\n", $lno, $msg ); +} + + +##------------------------------------------------------------------------ +# Used to create list of all multi-state objects from a list of +# dimensions. It returns an array containing all elements of the +# multidimensional array named $name. +# e.g. expand_object("R", 2,2) returns the array +# (R(0,0), R(1,0), R(0,1), R(1,1) +# Earlier indices vary faster than later ones. + +sub expand_object{ + my $name= shift; + my @lengths=@{$t=shift}; + my @equiv=@{$t=shift}; + my @olist=(""); + + for my $i (0..$#lengths){ + my @new_olist=(); + my $sep= ($i==$#lengths) ? "" : ","; + # array of earlier indices that are equivalent to index $i + my @eq=(); + if (my $class= $equiv[$i]){ + for $j (0..$i-1){ + ($equiv[$j]==$class) && push @eq,$j; + } + } + for $state (0..($lengths[$i]-1)){ + OBJ: + for $obj (@olist){ + # Skip this object if the current state is greater + # than the state of index equivalent to the current one. + if (@eq){ + my @states=split(',',$obj); + for $j (@eq){ + ($state>$states[$j]) && next OBJ; + } + } + push @new_olist, $obj.$state.$sep; + } + } + @olist= @new_olist; + } + + # Enclose indices in parentheses and prepend spcies name + for $obj (@olist){ + $obj= $name."(".$obj.")"; + } + + return(@olist); +} + +##--------------------------------------------------------------------------- +# Create aggregates from lists of species in rows of matrix a. +# This subroutine uses a depth first algoritm, meaning here that the +# most distant index changes fastest. +# The second subroutine uses a breadth first algoritm, meaning here that the +# most nearest index changes fastest. +##--------------------------------------------------------------------------- + +sub make_aggregates{ + my @a= @{$t= shift}; + + my $idepth=0; + my $max_depth=$#a; + my @olist=(); + my @agg=(); + my %agg_hash=(); + + for $i (0..$#a){$iptrs[$i]=0;} + push @olist, $a[0][0]; + + while(1){ + #descend until idepth==max_depth + while($idepth<$max_depth){ + ++$idepth; + last if ($idepth==$max_depth); + # set ptr at new depth to start of array + $iptrs[$idepth]=0; + push @olist, $a[$idepth][0]; + } + + # loop over ptrs at lowest depth + my @obj_low= @{$a[$max_depth]}; +# my $eq=$equiv[$idepth]; + for $obj (@obj_low){ + push @olist, $obj; + my $new_agg= join(".", sort by_obj @olist); + my $new_agg_sort= join(".", sort by_obj @olist); + # Only add aggregate that is in sort order + #($new_agg eq $new_agg_sort) && push @agg, $new_agg; + # Another way is to add aggregate first time it is encountered + ($agg_hash{$new_agg}++==0) && push @agg, $new_agg; + pop @olist; + } + + # go back up to depth where elements are not exhausted + # stop when no more elements at any level + while($idepth>=0){ + --$idepth; + last if ($idepth<0); + pop @olist; + if (($iptr=++$iptrs[$idepth])<=$#{$a[$idepth]}){ + push @olist, $a[$idepth][$iptr]; + last; + } + } + last if ($idepth<0); + } +# print join("\n", @agg),"\n"; + return(@agg); +} + +##------------------------------------------------------------------------ +# Returns the total cputime (user+system) of the current process and +# all children since the last call to cpu_time. +# Optional argument can be used to reset the offset. +# Call cpu_time(0) to tare (i.e. "zero") the clock. +{ + my $store_time=0; + sub cpu_time + { + my $prev_time = @_ ? shift @_ : $store_time; + my $curr_time = sum times; + $store_time = $curr_time; + return $curr_time - $prev_time; + } +} + +# Compute average and standard deviation over a set of data in +# format +# time1 y1 ... yN +# ... +# timeM y1 ... yN +# + +# This routine returns data sets in xmgrace format. +# Sets are written separately, in format time val dval, where dval +# is the standard deviation of the average over all runs. + +sub average_runs{ + my $outfile=shift; + + my $nfile=0; + my @t=(); + my $ng; + for my $file (@_){ + open(IN, $file); + my $i_t=0; + while(){ + next if (/^\#/); + my($time, @dat)=split(' '); + if ($nfile==1){ + push @t, $time; + $ng= $#dat; + } + for my $j(0..$#dat){ + $y[$i_t][$j][$nfile]= $dat[$j]; + } + ++$i_t; + } + close(IN); + ++$nfile; + } + + # Write results to outfile + open(OUT,">$outfile"); + for $j (0..$ng){ + for my $i (0..$#t){ + print OUT $t[$i]; + my ($sig, $avg)= &stddev(@{$y[$i][$j]}); + print OUT " ", $avg; + print OUT " ", $sig; + print OUT "\n"; + } + print OUT "&\n"; + } + close(OUT); +} + +sub average{ + return -1 unless $#_>=0; + local($sum)=0.0; + foreach $val (@_){ + $sum+=$val; + } + return $sum/($#_+1); +} + +sub stddev{ + return -1 unless $#_>=0; + local($sum)=0.0; + local($average)= &average(@_); + foreach $val (@_){ + $sum+=SQR($val-$average); + } + return (sqrt($sum/$#_), $average); # This is the correct formula for the + # variance---denom contains (n-1) +} + +# Basic utilities + +sub SQR{ + local($x)=shift; + return ($x*$x); +} + + +sub log10 { + my $x=shift; + return log($x)/log(10); +} + +sub MAX{ + my $a=shift; + my $b=shift; + + return(($a>=$b)? $a : $b); +} + +sub MIN{ + my $a=shift; + my $b=shift; + + return(($a<=$b)? $a : $b); +} + +sub bynum {$a<=>$b;} + +1; diff --git a/libvcell/vcell_install/bionetgen/Perl2/Boolean2BNGL/ABC_example.txt b/libvcell/vcell_install/bionetgen/Perl2/Boolean2BNGL/ABC_example.txt new file mode 100644 index 0000000..c64c23b --- /dev/null +++ b/libvcell/vcell_install/bionetgen/Perl2/Boolean2BNGL/ABC_example.txt @@ -0,0 +1,7 @@ +A = False +B = False +C = True + +1: A* = B or C +1: B* = not A and C +1: C* = A and not C diff --git a/libvcell/vcell_install/bionetgen/Perl2/Boolean2BNGL/Boolean2BNGL.pl b/libvcell/vcell_install/bionetgen/Perl2/Boolean2BNGL/Boolean2BNGL.pl new file mode 100644 index 0000000..3a340d8 --- /dev/null +++ b/libvcell/vcell_install/bionetgen/Perl2/Boolean2BNGL/Boolean2BNGL.pl @@ -0,0 +1,222 @@ +#!/usr/bin/perl + +use strict; +use warnings; +use File::Spec; + +my @NODES = (); + +my @parameters = (); +my @molecule_types = (); +my @seed_species = (); +my @observables = (); +my @functions = (); +my @reaction_rules = (); + +my $file = shift @ARGV; + +my $update_mode = (@ARGV) ? shift @ARGV : 'GSP'; # ROA, GA, GSP +$update_mode =~ tr/a-z/A-Z/; # make upper case +if ( $update_mode eq 'ROA' || $update_mode eq 'GA' || $update_mode eq 'GSP' ){ + printf "Boolean update mode: '$update_mode'\n"; +} +else{ + printf "Boolean update mode '$update_mode' not recognized. Allowed modes are 'ROA', 'GA', and 'GSP'.\n"; +} + +my $include_reset = ($update_mode eq 'GSP') ? 0 : 1; + +# determine output filename +if (not File::Spec->file_name_is_absolute( $file )){ + $file = File::Spec->rel2abs($file); +} +my ($vol, $dir, $filename) = File::Spec->splitpath( $file ); +my $outfile = $filename; +$outfile =~ s/\.\w+$/_$update_mode\.bngl/; +$outfile = File::Spec->catfile( $vol, $dir, $outfile ); + +# read entire file as a string +local $/ = undef; +open FILE, $file or die "Couldn't open file: $!"; +binmode FILE; +my $text = ; +close FILE; +$text =~ s/\r\n*/\n/g; # remove Windows-style carriage returns +my @lines = split('\n', $text); + +# read line-by-line +my $n_rules = 0; +foreach my $line (@lines) +{ + $line =~ tr/A-Z/a-z/; # Make everything lower case + if ( $line =~ /^\s*(\w+)\s*=\s*([t|f])/ ) + { + # MOLECULE TYPES + my $mt = $1; + $mt .= "(state~0~1"; + if ($include_reset){ $mt .= ",reset~N~Y" } + $mt .= ")"; + push @molecule_types, $mt; + + # SEED SPECIES + my $ss = $1; + my $state = ($2 eq 't') ? '1' : '0'; + $ss .= "(state~$state"; + if ($include_reset){ $ss .= ",reset~N"; } + $ss .= ") 1"; + push @seed_species, $ss; + + # OBSERVABLES + my $obs = $1; + $obs =~ tr/a-z/A-Z/; # Make observable names all upper case + $obs = "Molecules " . $obs . " " . $1 . "(state~1)"; + push @observables, $obs; + } + elsif( $line =~ /^\s*(\d+):\s*(\w+)\*\s*=\s*(.+)/ ) + { + my $rank = $1; + my $node = $2; + my $func = $3; + + push @NODES, $node; + + # FUNCTIONS + my $fname = "${node}_func()"; + + $func =~ tr/a-z/A-Z/; # make everything upper case + $func =~ s/\(\s+/\(/g; # remove whitespace after '(' character + $func =~ s/\s+\)/\)/g; # remove whitespace before ')' character + $func =~ s/\s+or\s+/ \|\| /ig; # replace 'or' with '||' + $func =~ s/\s+and\s+/ \&\& /ig; # replace 'and' with '&&' + $func =~ s/(\s*)not\s+/$1!/ig; # replace 'not' with '!' (also remove trailing whitespace) + $func =~ s/(\w+)/$1>0.5/g; # replace all 'ABC' with 'ABC>0.5' + $func =~ s/!(\w+)>0.5/$1<0.5/g; # replace all '!ABC>0.5' with 'ABC<0.5' + + $func = "$fname if($func, 1, 0)"; + push @functions, $func; + + # RULES + my $rate = "1"; + if ($rank > 1){ $rate .= "/$rank"; } + + $n_rules++; + my $rule_f = "R" . $n_rules . ": $node(state"; + if ($include_reset){ $rule_f .= ",reset~N"; } + $rule_f .= ") -> $node(state~1"; + if ($include_reset){ $rule_f .= ",reset~Y"; } + $rule_f .= ") if($fname>0.5,$rate,0)"; + push @reaction_rules, $rule_f; + + $n_rules++; + my $rule_r = "R" . $n_rules . ": $node(state"; + if ($include_reset){ $rule_r .= ",reset~N"; } + $rule_r .= ") -> $node(state~0"; + if ($include_reset){ $rule_r .= ",reset~Y"; } + $rule_r .= ") if($fname<0.5,$rate,0)"; + push @reaction_rules, $rule_r; + } +} + +if ($update_mode eq 'GA'){ + push @reaction_rules, "\n # reset rules"; + foreach my $node (@NODES){ + $n_rules++; + my $rule = "R" . $n_rules . ": $node(reset~Y) -> $node(reset~N) 1e10"; + push @reaction_rules, $rule; + } +} +elsif ($update_mode eq 'ROA'){ + push @parameters, "N_NODES " . scalar(@NODES); + unshift @molecule_types, "RESET(reset~N~Y)\n #"; + unshift @seed_species, "RESET(reset~N) 1\n #"; + my $obs = "Molecules N_FIRED"; + foreach my $node (@NODES){ + $obs .= " $node(reset~Y)" + } + unshift @observables, $obs . "\n #"; + push @reaction_rules, "\n # reset rules"; + $n_rules++; + push @reaction_rules, "R" . $n_rules . ": RESET(reset~N) <-> RESET(reset~Y) 1e10*if(N_FIRED>(N_NODES-0.5),1,0), 1e10*if(N_FIRED<0.5,1,0)"; + foreach my $node (@NODES){ + $n_rules++; + my $rule = "R" . $n_rules . ": $node(reset~Y) + RESET(reset~Y) -> $node(reset~N) + RESET(reset~Y) 1e10"; + push @reaction_rules, $rule; + } +} + +# Print to file +open FILE, ">", $outfile or die "Couldn't open file: $!"; + +print FILE "# Translation of Boolean model in " . $filename . " to BNGL format within the " . $update_mode . " (" . + ( ($update_mode eq 'ROA') ? "random-order asynchronous" : ($update_mode eq 'GA') ? "general asynchronous" : + ($update_mode eq 'GSP') ? "Gillespie" : "UNKNOWN" ) . ") update mode.\n"; + +print FILE "begin model\n"; + +print FILE "begin parameters\n"; +foreach my $i (@parameters){ + print FILE " $i\n"; +} +print FILE "end parameters\n"; + +print FILE "begin molecule types\n"; +foreach my $i (@molecule_types){ + print FILE " $i\n"; +} +print FILE "end molecule types\n"; + +print FILE "begin seed species\n"; +foreach my $i (@seed_species){ + print FILE " $i\n"; +} +print FILE "end seed species\n"; + +print FILE "begin observables\n"; +foreach my $i (@observables){ + print FILE " $i\n"; +} +print FILE "end observables\n"; + +print FILE "begin functions\n"; +foreach my $i (@functions){ + print FILE " $i\n"; +} +print FILE "end functions\n"; + +print FILE "begin reaction rules\n"; +foreach my $i (@reaction_rules){ + print FILE " $i\n"; +} +print FILE "end reaction rules\n"; + +print FILE "end model\n"; + +# actions +print FILE "\n"; +print FILE "# generate_network({overwrite=>1})\n\n"; + +my $n_nodes = scalar(@NODES); + +if ($update_mode eq 'ROA'){ + my $n_rounds = 15; + print FILE "# Simulate for N_ROUNDS = 15 update rounds, outputting every round. Note that with N_NODES = $n_nodes, the\n"; + print FILE "# average time for each update round is 1 + 1/2 + 1/3 + ... + 1/$n_nodes < $n_nodes. Thus, 't_end' is set to\n"; + print FILE "# $n_nodes*$n_rounds*100 (N_NODES*N_ROUNDS*100), a number large enough to ensure that 'max_sim_steps' is reached first.\n"; + print FILE "#\n"; + print FILE "# simulate({method=>\"ssa\",t_end=>($n_nodes*$n_rounds*100),output_step_interval=>($n_nodes*2+2),max_sim_steps=>(($n_nodes*2+2)*$n_rounds),print_CDAT=>0,verbose=>1})\n"; +} +elsif ($update_mode eq 'GA'){ + print FILE "# Simulate for 30 time units, outputting every time unit.\n"; + print FILE "#\n"; + print FILE "# simulate({method=>\"ssa\",t_end=>30,n_steps=>30,print_CDAT=>0,verbose=>1})\n\n"; + + print FILE "# Simulate for 30 \"update rounds\", outputting every round. This allows for a comparison with the ROA update scheme.\n"; + print FILE "# With N_NODES = $n_nodes, each round corresponds to $n_nodes*2 reaction firings (one state-change and one reset rule per node).\n"; + print FILE "# On average, this takes one time unit. Thus, 't_end' is set to 30*100 to ensure that 'max_sim_steps' is reached first.\n"; + print FILE "#\n"; + print FILE "# simulate({method=>\"ssa\",t_end=>(30*100),output_step_interval=>($n_nodes*2),max_sim_steps=>(($n_nodes*2)*30),print_CDAT=>0,verbose=>1})\n"; +} +elsif ($update_mode eq 'GSP'){ + print FILE "# Simulate for 30 time units, outputting every time unit.\n"; + print FILE "# simulate({method=>\"ssa\",t_end=>30,n_steps=>30,print_CDAT=>0,verbose=>1})\n"; +} diff --git a/libvcell/vcell_install/bionetgen/Perl2/Boolean2BNGL/Tcell_model_Nov2013_LAH.txt b/libvcell/vcell_install/bionetgen/Perl2/Boolean2BNGL/Tcell_model_Nov2013_LAH.txt new file mode 100644 index 0000000..0eb691f --- /dev/null +++ b/libvcell/vcell_install/bionetgen/Perl2/Boolean2BNGL/Tcell_model_Nov2013_LAH.txt @@ -0,0 +1,110 @@ +FLUSH = False +TCR = False +TCR_LOW = False +TCR_HIGH = True +CD28 = True +TGFBETA = False +IL2 = False +IL2R = False +AP1 = False +FOS = False +FOS_D =False +FOS_DD = False +FOS_DDD = False +JUN = False +ERK = False +MEK2 = False +TAK1 = False +MKK7 = False +JNK = False +RAF = False +RAS = False +CA = False +NFAT = False +PKCTHETA = False +NFKAPPAB = False +PI3K_LOW = False +PI3K_HIGH = False +PI3K = False +PIP3_LOW = False +PIP3_HIGH = False +PIP3 = False +PTEN = True +PDK1 = False +AKT = False +MTORC1 = False +MTORC2 = False +MTOR = False +MTORC1_D = False +MTORC2_D = False +MTORC2_DD = False +MTOR_D = False +MTOR_DD = False +MTOR_DDD = False +MTOR_DDDD = False +RHEB = False +TSC = True +S6K1 = False +PS6 = False +SMAD3 = False +JAK3 = False +STAT5 = False +STAT5_D = False +STAT5_DD = False +STAT5_DDD = False +FOXP3 = False +CD25 = False +CD122 = True +CD132 = True +IL2_EX = False +AKT_OFF = False +MTORC1_OFF = False +NFAT_OFF = False + +1: TCR_HIGH* = not FLUSH +1: TCR* = TCR_LOW or TCR_HIGH +1: RAS* = (TCR and CD28) or (RAS and IL2_EX and IL2R) +1: RAF* = RAS +1: MEK2* = RAF +1: ERK* = MEK2 +1: FOS* = ERK +1: PKCTHETA* = TCR_HIGH or (TCR_LOW and CD28 and MTORC2) +1: TAK1* = PKCTHETA +1: MKK7* = TAK1 +1: JNK* = MKK7 +1: JUN* = JNK +1: FOS_D* = FOS +1: FOS_DD* = FOS_D +1: AP1* = FOS_DD and JUN +1: CA* = TCR +1: NFKAPPAB* = PKCTHETA or AKT +1: NFAT* = CA and not NFAT_OFF +1: IL2* = ((AP1 and NFAT and NFKAPPAB) or IL2) and not FOXP3 +1: IL2R* = CD25 and CD122 and CD132 +1: PI3K_LOW* = (TCR_LOW and CD28) or (PI3K_LOW and IL2_EX and IL2R) +1: PI3K_HIGH* = (TCR_HIGH and CD28) or (PI3K_HIGH and IL2_EX and IL2R) +1: PI3K* = PI3K_LOW or PI3K_HIGH +1: PIP3_HIGH* = PI3K_HIGH and not PTEN +1: PIP3_LOW* = PI3K_LOW and not PTEN +1: PIP3* = PIP3_LOW or PIP3_HIGH +1: PDK1* = PIP3 +1: AKT* = PDK1 and MTORC2 and not AKT_OFF +1: TSC* = not AKT +1: RHEB* = not TSC +1: MTORC1* = RHEB and not MTORC1_OFF +1: MTORC2* = PI3K_HIGH or (PI3K_LOW and not S6K1) +1: MTORC1_D* = MTORC1 +1: MTORC2_D* = MTORC2 +1: MTOR* = MTORC1_D and MTORC2_D +1: MTOR_D* = MTOR +1: MTOR_DD* = MTOR_D +1: S6K1* = MTORC1 +1: PS6* = S6K1 +1: SMAD3* = TGFBETA +1: JAK3* = IL2R and IL2_EX +1: STAT5* = JAK3 +1: STAT5_D* = STAT5 +1: FOXP3* = (not MTOR_DD and STAT5) or (NFAT and SMAD3) +1: CD25* = FOXP3 or (AP1 and NFAT and NFKAPPAB) or STAT5 +1: PTEN* = (not TCR_HIGH and PTEN) or (not TCR_HIGH and FOXP3) +1: IL2_EX* = IL2 or IL2_EX diff --git a/libvcell/vcell_install/bionetgen/Perl2/Boolean2BNGL/Tcell_model_Oct2013.txt b/libvcell/vcell_install/bionetgen/Perl2/Boolean2BNGL/Tcell_model_Oct2013.txt new file mode 100644 index 0000000..651c4b9 --- /dev/null +++ b/libvcell/vcell_install/bionetgen/Perl2/Boolean2BNGL/Tcell_model_Oct2013.txt @@ -0,0 +1,108 @@ +TCR = False +TCR_LOW = False +TCR_HIGH = True +CD28 = True +TGFBETA = False +IL2 = False +IL2R = False +AP1 = False +FOS = False +FOS_D =False +FOS_DD = False +FOS_DDD = False +JUN = False +ERK = False +MEK2 = False +TAK1 = False +MKK7 = False +JNK = False +RAF = False +RAS = False +CA = False +NFAT = False +PKCTHETA = False +NFKAPPAB = False +PI3K_LOW = False +PI3K_HIGH = False +PI3K = False +PIP3_LOW = False +PIP3_HIGH = False +PIP3 = False +PTEN = True +PDK1 = False +AKT = False +MTORC1 = False +MTORC2 = False +MTOR = False +MTORC1_D = False +MTORC2_D = False +MTORC2_DD = False +MTOR_D = False +MTOR_DD = False +MTOR_DDD = False +MTOR_DDDD = False +RHEB = False +TSC = True +S6K1 = False +PS6 = False +SMAD3 = False +JAK3 = False +STAT5 = False +STAT5_D = False +STAT5_DD = False +STAT5_DDD = False +FOXP3 = False +CD25 = False +CD122 = True +CD132 = True +IL2_EX = False +AKT_OFF = False +MTORC1_OFF = False +NFAT_OFF = False + +1: TCR* = TCR_LOW or TCR_HIGH +1: RAS* = ( TCR and CD28 ) or (RAS and IL2_EX and IL2R) +1: RAF* = RAS +1: MEK2* = RAF +1: ERK* = MEK2 +1: FOS* = ERK +1: PKCTHETA* = TCR_HIGH or (TCR_LOW and CD28 and MTORC2) +1: TAK1* = PKCTHETA +1: MKK7* = TAK1 +1: JNK* = MKK7 +1: JUN* = JNK +1: FOS_D* = FOS +1: FOS_DD* = FOS_D +1: AP1* = FOS_DD and JUN +1: CA* = TCR +1: NFKAPPAB* = PKCTHETA or AKT +1: NFAT* = CA and not NFAT_OFF +1: IL2* = ((AP1 and NFAT and NFKAPPAB) or IL2) and not FOXP3 +1: IL2R* = CD25 and CD122 and CD132 +1: PI3K_LOW* = (TCR_LOW and CD28) or (PI3K_LOW and IL2_EX and IL2R) +1: PI3K_HIGH* = (TCR_HIGH and CD28) or (PI3K_HIGH and IL2_EX and IL2R) +1: PI3K* = PI3K_LOW or PI3K_HIGH +1: PIP3_HIGH* = PI3K_HIGH and not PTEN +1: PIP3_LOW* = PI3K_LOW and not PTEN +1: PIP3* = PIP3_LOW or PIP3_HIGH +1: PDK1* = PIP3 +1: AKT* = PDK1 and MTORC2 and not AKT_OFF +1: TSC* = not AKT +1: RHEB* = not TSC +1: MTORC1* = RHEB and not MTORC1_OFF +1: MTORC2* = PI3K_HIGH or (PI3K_LOW and not S6K1) +1: MTORC1_D* = MTORC1 +1: MTORC2_D* = MTORC2 +1: MTOR* = MTORC1_D and MTORC2_D +1: MTOR_D* = MTOR +1: MTOR_DD* = MTOR_D +1: S6K1* = MTORC1 +1: PS6* = S6K1 +1: SMAD3* = TGFBETA +1: JAK3* = IL2R and IL2_EX +1: STAT5* = JAK3 +1: STAT5_D* = STAT5 +1: FOXP3* = (not MTOR_DD and STAT5) or (NFAT and SMAD3) +1: CD25* = FOXP3 or (AP1 and NFAT and NFKAPPAB) or STAT5 +1: PTEN* = (not TCR_HIGH and PTEN) or (not TCR_HIGH and FOXP3) +1: IL2_EX* = IL2 or IL2_EX diff --git a/libvcell/vcell_install/bionetgen/Perl2/Boolean2BNGL/Tcell_model_v16.txt b/libvcell/vcell_install/bionetgen/Perl2/Boolean2BNGL/Tcell_model_v16.txt new file mode 100644 index 0000000..c1059f4 --- /dev/null +++ b/libvcell/vcell_install/bionetgen/Perl2/Boolean2BNGL/Tcell_model_v16.txt @@ -0,0 +1,20 @@ +TCR = False TCR_LOW = False TCR_HIGH = True CD28 = True TGFBETA = False IL2 = False IL2R = False AP1 = False FOS = False FOS_D =False FOS_DD = False FOS_DDD = False JUN = False ERK = False MEK2 = False +MEK1 = False TAK1 = False MKK7 = False JNK = False RAF = False RAS = False CA = False NFAT = False PKCTHETA = False NFKAPPAB = False PI3K_LOW = False PI3K_HIGH = False PI3K = False PIP3_LOW = False PIP3_HIGH = False PIP3 = False PTEN = True PDK1 = False AKT = False MTORC1 = False MTORC2 = False MTOR = False MTORC1_D = False MTORC2_D = False MTORC2_DD = False MTOR_D = False MTOR_DD = False MTOR_DDD = False MTOR_DDDD = False RHEB = False TSC = True S6K1 = False PS6 = False SMAD3 = False JAK3 = False STAT5 = False STAT5_D = False STAT5_DD = False STAT5_DDD = False FOXP3 = False CD25 = False CD122 = True CD132 = True IL2_EX = False +FOXO1 = True +FOXO1_P = False +FOXO1_P_D = False +FOXO1_P_DD = False +FOXO1_P_DDD = False +CK2 = False +AKT_OFF = False +MTORC1_OFF = False +NFAT_OFF = False +IL2RA = False +IL2RA_D = False + 1: TCR* = TCR_LOW or TCR_HIGH +1: CK2* = TCR_HIGH 1: RAS* = (TCR and CD28) or (RAS and IL2_EX and IL2R) 1: RAF* = RAS 1: MEK2* = RAF +1: MEK1* = RAF 1: ERK* = MEK2 1: FOS* = ERK 1: PKCTHETA* = TCR_HIGH or (TCR_LOW and CD28 and MTORC2) 1: TAK1* = PKCTHETA 1: MKK7* = TAK1 1: JNK* = MKK7 1: JUN* = JNK 1: FOS_D* = FOS 1: FOS_DD* = FOS_D 1: AP1* = FOS and JUN 1: CA* = TCR 1: NFKAPPAB* = PKCTHETA or AKT 1: NFAT* = CA and not NFAT_OFF 1: IL2* = ((AP1 and NFAT and NFKAPPAB) or IL2) and not FOXP3 1: IL2R* = CD25 and CD122 and CD132 +1: IL2RA* = IL2 and IL2R +1: IL2RA_D* = IL2RA 1: PI3K_LOW* = (TCR_LOW and CD28) or (PI3K_LOW and IL2RA_D) 1: PI3K_HIGH* = (TCR_HIGH and CD28) or (PI3K_HIGH and IL2RA_D) 1: PI3K* = PI3K_LOW or PI3K_HIGH 1: PIP3_HIGH* = PI3K_HIGH and not PTEN 1: PIP3_LOW* = PI3K_LOW and not PTEN 1: PIP3* = PIP3_LOW or PIP3_HIGH 1: PDK1* = PIP3 1: AKT* = (PDK1 and MTORC2) and not AKT_OFF 1: TSC* = not AKT 1: RHEB* = not TSC 1: MTORC1* = RHEB and not MTORC1_OFF 1: MTORC2* = PI3K_HIGH or (PI3K_LOW and not S6K1) 1: MTORC1_D* = MTORC1 1: MTORC2_D* = MTORC2 1: MTOR* = MTORC1_D and MTORC2_D 1: MTOR_D* = MTOR 1: MTOR_DD* = MTOR_D +1: MTOR_DDD* = MTOR_DD 1: S6K1* = MTORC1 1: PS6* = S6K1 1: SMAD3* = TGFBETA 1: JAK3* = IL2R and IL2_EX 1: STAT5* = JAK3 1: STAT5_D* = STAT5 1: FOXP3* = (not MTOR_DD and (STAT5 or (NFAT and AP1 and STAT5 and FOXO1))) or (NFAT and SMAD3) 1: CD25* = FOXP3 or (AP1 and NFAT and NFKAPPAB) or STAT5 1: PTEN* = (FOXO1 and MEK1) and not CK2 +1: FOXO1* = not AKT 1: IL2_EX* = IL2 or IL2_EX \ No newline at end of file diff --git a/libvcell/vcell_install/bionetgen/Perl2/Cache.pm b/libvcell/vcell_install/bionetgen/Perl2/Cache.pm new file mode 100644 index 0000000..8bd6b4a --- /dev/null +++ b/libvcell/vcell_install/bionetgen/Perl2/Cache.pm @@ -0,0 +1,93 @@ +package Cache; +# a simple class for stowing and fetching things by label + +# pragmas +use strict; +use warnings; + +use constant DEFAULT_LABEL => 'DEFAULT'; + +# Structure containing BioNetGen model data +sub new +{ + my ($class) = @_; + my $cache = {}; + bless ($cache, $class); + return $cache; +}; + +# copy cache (this will NOT copy objects contained in cache) +sub copy +{ + my ($cache) = @_; + my $copy = {}; + %$copy = %$cache; + bless ($copy, ref $cache); + return $copy; +} + +# stow an item in cache +sub cache +{ + my ($cache, $item, $label) = @_; + + unless (defined $label) + { $label = DEFAULT_LABEL; } + + $cache->{$label} = $item; +} + +# browse an item in cache (get item reference, but do not remove from cache) +sub browse +{ + my ($cache, $label) = @_; + + unless (defined $label) + { $label = DEFAULT_LABEL; } + + return (exists $cache->{$label} ? $cache->{$label} : undef); +} + +# fetch an item from cache (item is removed from cache!) +sub fetch +{ + my ($cache, $label) = @_; + + unless (defined $label) + { $label = DEFAULT_LABEL; } + + my $item = undef; + if (exists $cache->{$label}) + { + $item = $cache->{$label}; + delete $cache->{$label}; + } + return $item; +} + +# check if a label is defined +sub is_label_defined +{ + my ($cache, $label) = @_; + + unless (defined $label) + { $label = DEFAULT_LABEL; } + + return exists $cache->{$label}; +} + +# get the number of items in the cache +sub size +{ + my ($cache) = @_; + return (scalar keys %$cache); +} + +# empty the cache +sub empty +{ + my ($cache) = @_; + $cache = {}; +} + +1; diff --git a/libvcell/vcell_install/bionetgen/Perl2/CartesianProduct.pm b/libvcell/vcell_install/bionetgen/Perl2/CartesianProduct.pm new file mode 100644 index 0000000..6a197b4 --- /dev/null +++ b/libvcell/vcell_install/bionetgen/Perl2/CartesianProduct.pm @@ -0,0 +1,309 @@ +package CartesianProduct; +### A class for iterating over elements of a cartesian product + + +use Class::Struct; +use FindBin; +use lib $FindBin::Bin; + +use warnings; +use strict; + + +### Members +struct CartesianProduct => +{ + Lists => '@', # a list of references to lists + NumLists => '$', # the number of lists participating in this CartesianProduct + ListPosition => '$', # minimum of list indices that were changed in last advance + FirstIdx => '@', # a list of indices corresponding to the minimum element to iterate over + CurrentIdx => '@', # a list of indices corresponding to the current element of the Cartesian product + LastIdx => '@', # a list of indices corresponding to the end of each list + MoreElements => '$' # a boolean value: 1 if there are more elements in the Cartesian product, 0 otherwise. +}; + + +### Methods: +### +### (public) +### $cp = CartesianProduct::new(); +### $cp_copy = $cp->copy(); +### bool = $cp->initialize( \@lists ); +### bool = $cp->getNext( \@elem ); +### bool = $cp->update( \@new_items, $list_idx ); +### bool = $cp->validate( ); +### +### (private) +### void = $cp->advance( ); +### + + + +# Copy the Cartesian Product +sub copy +{ + my $cp = shift @_; + + my $cp_copy = CartesianProduct::new(); + $cp_copy->Lists( [@{$cp->Lists}] ); + $cp_copy->NumLists( $cp->NumLists ); + $cp_copy->ListPosition( $cp->ListPosition ); + $cp_copy->FirstIdx( [@{$cp->FirstIdx}] ); + $cp_copy->CurrentIdx( [@{$cp->CurrentIdx}] ); + $cp_copy->LastIdx( [@{$cp->LastIdx}] ); + $cp_copy->MoreElements( $cp->MoreElements ); + + return $cp_copy; +} + + + +### +### +### + + + +# Call this method to initialize a new CartesianProduct with a reference +# to a set of lists provided as the first argument. Returns true if the CartesianProduct +# is initialized correctly. +sub initialize +{ + my $cp = shift; + my $lists = shift; + + # get item lists + unless ( ref $lists eq 'ARRAY' ) + { return 0; } + + $cp->Lists( $lists ); + $cp->NumLists( scalar @$lists ); + + + # setup index vectors + my $current_idx = []; + my $first_idx = []; + my $last_idx = []; + + my $elem_exist = 1; + my $ii = 0; + while ( $ii < $cp->NumLists ) + { + push @$current_idx, 0; + push @$first_idx, 0; + push @$last_idx, scalar @{$cp->Lists->[$ii]}; + $elem_exist *= scalar @{$cp->Lists->[$ii]}; + ++$ii; + } + + $cp->ListPosition( 0 ); + $cp->FirstIdx( $first_idx ); + $cp->CurrentIdx( $current_idx ); + $cp->LastIdx( $last_idx ); + $cp->MoreElements( $elem_exist ); + + return 1; +} + + + +### +### +### + + + +# call this method to load the next element of the CartesianProduct +# into the reference provided as the first argument. Returns true if next +# element was loaded into array at pointer $elem; returns false if no more elements +# are available. +sub getNext +{ + my $cp = shift; # this CartesianProduct object + my $elem = shift; # pointer to array that store elements + + if ( $cp->MoreElements ) + { # load current element and return true + my $ii = $cp->ListPosition; + while ( $ii < $cp->NumLists ) + { + $elem->[$ii] = $cp->Lists->[$ii]->[ $cp->CurrentIdx->[$ii] ]; + ++$ii; + } + $cp->advance(); + return 1; + } + else + { # no more elements, return false + return 0; + } +} + + +### +### +### + + + +# After iterating through all elements of the CartesianProduct, +# add @$new_items to the list at index $list_idx. +# Continue calling getNext to iterate over new elements of the cartesian product +# NOTE: must iterate through all new elements before calling update again +sub update +{ + my $cp = shift; + my $list_idx = shift; + my $new_items = shift; + + if ( $cp->MoreElements + or $cp->NumLists != scalar @{$cp->Lists} + or $list_idx < 0 + or $list_idx >= $cp->NumLists + or ref $new_items ne 'ARRAY' ) + { # invalid update! + return 0; + } + else + { + # update FirstIdx: point to first element in each list, except the updated list + # that will point to the first new element. + $cp->FirstIdx( [(0) x $cp->NumLists] ); + $cp->FirstIdx->[$list_idx] = @{$cp->Lists->[$list_idx]}; + + # CurrentIdx is the same as FirstIdx + $cp->CurrentIdx( [@{$cp->FirstIdx}] ); + + # add new_items to list + push @{$cp->Lists->[$list_idx]}, @$new_items; + + # update lastIdx + my $ii = 0; + my $elem_exist = $cp->NumLists ? 1 : 0; + while ( $ii < $cp->NumLists ) + { + $cp->LastIdx->[$ii] = scalar @{$cp->Lists->[$ii]}; + $elem_exist *= scalar @{$cp->Lists->[$ii]}; + ++$ii; + } + + $cp->ListPosition( 0 ); + + if ( scalar @$new_items and $elem_exist ) + { $cp->MoreElements(1); } + + return 1; + } +} + + + +### +### +### + + + +# This private method advances the index vector +sub advance +{ + my $cp = shift; + + if ( $cp->MoreElements ) + { + my $ii = $cp->NumLists - 1; + while ( $ii >= 0 ) + { + ++($cp->CurrentIdx->[$ii]); + last if ( $cp->CurrentIdx->[$ii] < $cp->LastIdx->[$ii] ); + $cp->CurrentIdx->[$ii] = $cp->FirstIdx->[$ii]; + --$ii; + } + + $cp->ListPosition($ii); + if ( $ii < 0 ) { $cp->MoreElements(0); } + } +} + + + + + + +### +### +### + + + +# This method validates the CartesianProduct state. +# Returns true if everything looks good, false otherwise. +sub validate +{ + my $cp = shift; + my $elem = (@_) ? shift : undef; + + # check for correct number of lists + unless ( defined $cp->NumLists + and @{$cp->Lists} == $cp->NumLists ) + { return 0; } + + # check that ListPosition is correctly defined + unless ( defined $cp->ListPosition + and $cp->ListPosition >= 0 + and $cp->ListPosition < $cp->NumLists ) + { return 0; } + + # check that CurrentIdx is defined + unless ( defined $cp->CurrentIdx ) + { return 0; } + + # check that LastIdx is defined + unless ( defined $cp->LastIdx ) + { return 0; } + + # If we were passed $elem, check that its the correct size + if ( defined $elem ) + { + unless ( @$elem == @{$cp->Lists} ) { return 0; } + } + + # loop over lists and check that everything is in order + my $ii = 0; + while ( $ii < $cp->NumLists ) + { + # make sure things are defined + unless ( defined $cp->Lists->[$ii] + and defined $cp->CurrentIdx->[$ii] + and defined $cp->LastIdx->[$ii] ) + { return 0; } + + # check that lastIndex is correct + unless ( $cp->LastIdx->[$ii] == @{$cp->Lists->[$ii]} ) + { return 0; } + + # check that currentIndex has a valid range + unless ( $cp->CurrentIdx->[$ii] >= 0 + and $cp->CurrentIdx->[$ii] < @{$cp->Lists->[$ii]} ) + { return 0; } + + # If we were passed $elem check that its defined correctly up to ListPosition + if ( defined $elem and $ii < $cp->ListPosition ) + { + unless ( $elem->[$ii] == $cp->Lists->[$ii]->[ $cp->CurrentIdx->[$ii] ] ) + { return 0; } + } + ++$ii; + } + + # everything checks out! + return 1; +} + + +### +### +### + + +1; diff --git a/libvcell/vcell_install/bionetgen/Perl2/Compartment.pm b/libvcell/vcell_install/bionetgen/Perl2/Compartment.pm new file mode 100644 index 0000000..fb2bf1f --- /dev/null +++ b/libvcell/vcell_install/bionetgen/Perl2/Compartment.pm @@ -0,0 +1,449 @@ +# $Id: Compartment.pm,v 1.1 2006/09/25 04:50:31 faeder Exp $ + +package Compartment; + +# pragmas +use strict; +use warnings; + +# Perl Modules +use Class::Struct; +use FindBin; +use lib $FindBin::Bin; + +# BNG Modules +use Expression; + + + +struct Compartment => { + Name => '$', # name of compartment (valid chars: \w). + SpatialDimensions => '$', # dimension of compartment: 0-3. + Size => 'Expression', # volume/area/length expression. + Outside => 'Compartment', # ref to compartment (if any) that contains this. + Inside => '@', # list of compartments contained by Compartment. [JSH] +}; + + +# get copy of compartment +# (careful here.. the Outside and Inside continue pointing to the same old place. +# If copying an entire compartment list, these references need to be updated after copy!) +sub copy +{ + my $comp = shift; + my $plist = (@_) ? shift : undef; + + my $comp_copy = Compartment::new(); + $comp_copy->Name( $comp->Name ); + $comp_copy->SpatialDimensions( $comp->SpatialDimensions ); + + $comp_copy->Size( $comp->Size->clone($plist) ) if ( defined $comp->Size ); + $comp_copy->Outside( $comp->Outside ) if ( defined $comp->Outside ); + + @{ $comp_copy->Inside } = @{ $comp->Inside }; + + return $comp_copy; +} + + + +### +### +### + + + +# after copying a compartment list, we need to relink the inside and outside neighbors +# the arguments should be the copied compartment and list +sub relinkNeighbors +{ + my $comp = shift; + my $clist = shift; + + # relink outside + $comp->Outside = $clist->lookup( $comp->Outside->Name ); + # relink inside + foreach my $inside_comp ( @{$comp->Inside} ) + { + $inside_comp = $clist->lookup( $inside_comp->Name ); + } +} + + + +### +### +### + + +sub newCompartment +# ($comp_ref, $err) = Compartment->newCompartment(name,dim,size[,outside]); +# creates a new compartment object +# sub added by justinshogg@gmail.com 18feb09 +{ + my ($class, $name, $dim, $size, $outside) = @_; + + $name =~ /^[\w]+$/ or return( undef, "newCompartment: attempt to define compartment with invalid name: '$name'." ); + $dim =~ /^[2-3]$/ or return( undef, "newCompartment: spatialDimension '$dim' must be integer in [2,3]." ); + ref $size eq 'Expression' or return( undef, "newCompartment: size parameter '$size' must be an expression." ); + + my $err = ''; + my $comp = Compartment->new(Name=>$name,SpatialDimensions=>$dim,Size=>$size); + $err = $comp->put_inside($outside) if ( defined $outside ); + + return($comp, $err); +} + + +### +### +### + + +sub put_inside +# $err = $comp->put_inside( $outside ); +# set $comp1->Outside = $comp; +{ + my ($comp, $outside) = @_; + + # check that $outside is a compartment! + ref $outside eq 'Compartment' + || return("Compartment->put_inside > Outside parameter '$outside' must be a Compartment."); + + !defined($comp->Outside) + || return("Compartment->put_inside: compartment is already contained by another compartment."); + + # enforce topology. (1) alternating dimensions: ..->volume->surface->volume->surface->.. + abs( $comp->SpatialDimensions - $outside->SpatialDimensions ) == 1 + || return("Compartment->put_inside: Outside has same dimension as compartment."); + + # enforce topology. (2) only one volume inside a surface + if ($comp->SpatialDimensions == 3 && $outside->SpatialDimensions == 2) + { + (@{$outside->Inside} == 0) + || return("Compartment->put_inside: Outside 2-D compartment already contains a 3-D compartment."); + } + + # all good, do the operation. + $comp->Outside($outside); + push @{$outside->Inside}, $comp; + return ''; +} + + + + +sub adjacent +# int = $comp1->adjacent( $comp2 ) +# return +1 if $comp1 is Outside of Comp2 +# return -1 if $comp2 is Outside of Comp1 +# return 0 if compartments are not adjacent +{ + my $comp1 = shift; + my $comp2 = shift; + + # Compartment 1 contains Compartment 2 + if ( defined $comp2->Outside ) + { + if ( $comp2->Outside == $comp1 ) + { return 1; } + } + # Compartment 2 contains Compartment 1 + if ( defined $comp1->Outside ) + { + if ( $comp1->Outside == $comp2 ) + { return -1; } + } + return 0; +} + + + + +sub is_surface_of +# int = $comp1->is_surface_of($comp2) +# return 1 if $comp1 is a surface facing volume $comp2 +# return -1 if $comp2 is a surface facing volume $comp1 +# else return 0. +# justinshogg@gmail.com 16feb2009 +{ + my ($comp1,$comp2) = @_; + my $adj = $comp1->adjacent($comp2); + if ($adj) + { return($comp2->SpatialDimensions - $comp1->SpatialDimensions); } + else + { return 0; } +} + + + +sub separated_by_surface +# int = Compartment1->separated_by_surface(Compartment2) +# return 1 if Compartment1 and Compartment2 are volumes +# separated by a surface and Comp1 is outer-most compartment. +# return -1 if Compartment1 and Compartment2 are volumes +# separated by a surface and Comp2 is outer-most compartment. +# return 0 otherwise. +# +# Note: assumes alternating tree topology +{ + my ($comp1, $comp2) = @_; + + # comp1 and comp2 must be volumes + return 0 unless ( ($comp1->SpatialDimensions==3) and ($comp2->SpatialDimensions==3) ); + + # check if comp1 and comp2 are separated by a membrane + # and comp1 is outer-most: + return -1 if ( defined $comp1->Outside + and defined $comp1->Outside->Outside + and ($comp1->Outside->Outside == $comp2) ); + + # and comp2 is outer-most: + return 1 if ( defined $comp2->Outside + and defined $comp2->Outside->Outside + and ($comp2->Outside->Outside == $comp1) ); + + return 0; +} + + +sub separated_by_volume +# int = Compartment1->separated_by_surface(Compartment2) +# return 1 if Compartment1 and Compartment2 are surfaces +# separated by a volume and the volume does not contain both surfaces. +# return -1 if Compartment1 and Compartment2 are surfaces +# separated by a volume and the volume contains both surfaces. +# return 0 otherwise. +# +# NOTE: assumes alternating tree topology +# for endocytosis: Both the Outside volume of the outermost surface +# and Inside volume of the innermost surface MUST EXIST. +# for exocytosis: Both of the Surfaces must have an Inside volume defined. +{ + my ($comp1, $comp2) = @_; + + # comp1 and comp2 must be surfaces + return 0 unless ( ($comp1->SpatialDimensions==2) and ($comp2->SpatialDimensions==2) ); + + # exocytosis + # check if comp1 and comp2 have the same Outside (and both contain some volume) + return -1 if ( defined $comp1->Outside + and defined $comp2->Outside + and ($comp1->Outside == $comp2->Outside) + and exists $comp1->Inside->[0] + and exists $comp2->Inside->[0] + ); + + # endocytosis + # Check if comp1 Outside == comp2 Inside + return 1 if ( defined $comp1->Outside + and defined $comp1->Outside->Outside + and ($comp1->Outside->Outside == $comp2) + and exists $comp1->Inside->[0] + and defined $comp2->Inside + ); + + # endocytosis + # Check if comp2 Outside == comp1 Inside + return 1 if ( defined $comp2->Outside + and defined $comp2->Outside->Outside + and ($comp2->Outside->Outside == $comp1) + and exists $comp2->Inside->[0] + and defined $comp1->Outside + ); + + return 0; +} + + + + +sub connected { +# $bool = connected( $comp1, $comp2, .. $comp3 ); +# check if a list of compartments are connected + my @nodes_conn= (shift); + my @nodes_left= @_; + + my $link_found; + while(@nodes_left){ + $link_found=0; + for my $n1 (@nodes_conn){ + for my $i (0..$#nodes_left){ + if ($n1->adjacent($nodes_left[$i])){ + push @nodes_conn, $nodes_left[$i]; + splice @nodes_left, $i, 1; + $link_found=1; + last; + } + } + last if $link_found; + } + last unless $link_found; + } + # Compartment graph is not connected unless link was found on last loop + return($link_found) +} + + + + +sub toString{ + my $comp=shift; + my $plist=(@_) ? shift : ""; + + my $string=""; + + $string.=$comp->Name; + $string.=" ".$comp->SpatialDimensions; + if ($plist){ + $string.=" ".$comp->Size->toString($plist); + } + if (my $ccomp=$comp->Outside){ + $string.=" ".$ccomp->Name; + } + return($string); +} + + + + +sub toXML{ + my $comp=shift; + my $indent=shift; + my $plist = (@_) ? shift : undef; + + my $string=$indent."Name."\""; + # spatialDimensions + $string.= " spatialDimensions=\"".$comp->SpatialDimensions."\""; + # size + my $size = $comp->Size->toString(); + unless ( BNGUtils::isReal($size) ) + { $size = $comp->Size->evaluate($plist); } # evaluate to a number +# $string.= " size=\"".$comp->Size->toString()."\""; + $string.= " size=\"".$size."\""; + # outside + if ($comp->Outside){ + $string.= " outside=\"".$comp->Outside->Name."\""; + } + + $string.="/>\n"; # short tag termination + + return($string); +} + +############DB################### +# This function calculates scaling factor for the compartment volumes/areas of compartments based on the user-specified volumes +#provided in the BNGL file. The scaling is determined by the ration of the user-specified volume and the default volume of a +# M-cell produced geometry, which in this case is a sphere. The default size of a MCell/Blender-created is r = 1 micron (volume +# = 4.19 cubic micron, and surface area is 12.57 sq. micron. The function first determines size of a sphere based on the sum of +# all nested compartment volumes (by calling the getMDLSize function). It then determines the linear scaling factor, which is the +# ratio from the volume of the sphere and the volume of the MCell/Blender-created default sphere. In addition, the function +# stores the first word from the first line into a hash called %shape. The first word referes to the name of the geometry object itself (in this +# case it is "Sphere". + + +sub getMDLgeometry +{ + my $comp = shift; + my $plist = shift; + my $geometry = shift; + my $object = shift; + my $shape = shift; + my $scale = shift; + my $string = ""; + + my $surf; + my $i=0; + foreach (@{$geometry}){ + if ($_ =~ /POLYGON_LIST/){ + $object->{$comp->Name} = $_; + $object->{$comp->Name} =~ s/POLYGON_LIST//; + $object->{$comp->Name} =~ s/^\s*//; + $object->{$comp->Name} =~ s/\s*$//; + $object->{$comp->Name} = $comp->Name."_".$object->{$comp->Name}; + } + + if ($_ =~ /DEFINE_SURFACE_REGIONS/){ + $surf = $geometry->[$i+2]; + $surf =~ s/^\s*//; + $surf =~ s/\s*$//; + } + ++$i; + } + + my $volume_mcell; + my $area_mcell; + my $volume; + my $area; + + if ($object->{$comp->Name} =~ /Sphere/){ + $volume_mcell = 4.1904762; # Default volume of sphere in Blender; + $area_mcell = 12.571429; # Default surface area of sphere in Blender; + $volume = getMDLSize($comp, $plist); # Volume of sphere inclosing the compartment and nested inside compartments + $area = 4.836624601*($volume)**(2/3); # Surface area of sphere + } + + + if ((!$comp->Outside) || ($comp->SpatialDimensions == 2)){ # Write geometries defined by 2D surfaces + $string = join "", map {$_=~ /POLYGON_LIST/ ? $comp->Name."_".$_ : $_ } (@{$geometry}); + $shape->{$comp->Name} .= $object->{$comp->Name}."[$surf]"; + my ($volume, $area) = ($comp->SpatialDimensions == 3) ? ($volume, undef) : (undef, $area); + # $volume is relevant only in the case of the outermost space if it has no defined boundary (in BNGL). + $scale->{$comp->Name} = (defined $volume) ? ($volume/$volume_mcell)**(1/3) : sqrt($area/$area_mcell); + } + + if (@{$comp->Inside}){ + foreach my $incomp (@{$comp->Inside}){ + $string .= getMDLgeometry($incomp,$plist,$geometry,$object,$shape,$scale); # Recursive call + } + } + return $string; +} + +# This function returns a reference to an array. The first array element is a compartment name. Subsequent elements are the names of nested compartments. +sub getMDLRelSite +{ + my $comp = shift; + my @array; + if ($comp->SpatialDimensions == 2){ + push(@array, $comp->Name); # The array contains a single element because membrane compartment does not hold any nested compartments. + return \@array; + } + + push (@array, $comp->Outside ? $comp->Outside->Name : $comp->Name); # If outermost 3D space, then name the 'hypothetical' outer membrane with the same name as the compartment + foreach (@{$comp->Inside}){ + push (@array, $_->Name); # First element is the primary compartment. Subsequent elements are nested compartments. + } + return \@array; +} + +# This function calculates total volume of a sphere (i.e., volume of (compartment + all inside compartments). +# Membrane volume is assumed zero regardless of the user-assigned value +# because potential contradiction can arise from independently assigning both the membrane and enclosed volume size +# Size of a sphere is only based on the assigned 3D volumes. + +sub getMDLSize +{ + my $comp = shift; + my $plist = shift; + my $custom_geometry = shift; + my $volume = 0; + my $childvolume = 0; + + $volume = $comp->Size->evaluate($plist); + return $volume if ($custom_geometry); + + $volume = 0 if ($comp->SpatialDimensions == 2); + + foreach my $child (@{$comp->Inside}){ # Calculate volume of all nested compartments inside the current compartment + $childvolume = $childvolume + $child->getMDLSize($plist, $custom_geometry); + } + $volume = $volume + $childvolume; # Sphere volume = volume of (current compartment + all nested compartments inside) + return ($volume); +} + +1; diff --git a/libvcell/vcell_install/bionetgen/Perl2/CompartmentList.pm b/libvcell/vcell_install/bionetgen/Perl2/CompartmentList.pm new file mode 100644 index 0000000..3dae0e5 --- /dev/null +++ b/libvcell/vcell_install/bionetgen/Perl2/CompartmentList.pm @@ -0,0 +1,240 @@ +# $Id:$ + +package CompartmentList; + +# pragmas +use strict; +use warnings; + +# Perl Modules +use Class::Struct; +use FindBin; +use lib $FindBin::Bin; + +# BNG Modules +use Compartment; +use ParamList; + + + + +struct CompartmentList => +{ + Array => '@', # list of Compartments + Hash => '%', # map from Compartment name to compartment object ref. + Used => '$' # Flag to indicate that compartment attribute is set in 1 or more species in model +}; + + +# copy the entire CompartmentList and all Compartments it contains +sub copy +{ + my $clist = shift @_; + my $plist = @_ ? shift @_ : undef; + + # create copy of list + my $clist_copy = CompartmentList->new(); + foreach my $comp ( @{$clist->Array} ) + { + my $comp_copy = $comp->copy( $plist ); + push @{$clist_copy->Array}, $comp_copy; + $clist_copy->Hash->{$comp_copy->Name} = $comp_copy; + } + $clist_copy->Used($clist->Used); # TODO: is this the best assumption? + + # fix links to inside and outside neighbors + foreach my $comp ( @{$clist_copy->Array} ) + { + $comp->relinkNeighbors( $clist_copy ); + } + + return $clist_copy; +} + + +### +### +### + + + +sub getNumCompartments +{ + my $clist = shift; + return scalar @{$clist->Array}; +} + + +### +### +### + + +# lookup a compartment by name. Returns reference or empty string +sub lookup +{ + my $clist = shift; + my $name = shift; + + if ( exists $clist->Hash->{$name} ) + { + return $clist->Hash->{$name}; + } + else + { + return ''; + } +} + + +### +### +### + + +sub add +# '' = @clist->add( cref1, cref2, ... crefN ) +# add compartment to a compartment list +# updated by justinshogg@gmail.com 17feb2009 +# overloaded method to add compartments by +# reference. +{ + my $clist = shift; # CompartmentList ref + my $comp = shift; + + ref $comp eq 'Compartment' + || return "CompartmentList: Attempt to add non-compartment object $comp to CompartmentList."; + + if ( exists $clist->Hash->{ $comp->Name } ) + { # compartment with same name is already in list + # swap old compartment for the new one + my $cref = $clist->Hash->{ $comp->Name }; + %{$cref} = %{$comp}; + } + else + { # add new compartment + $clist->Hash->{ $comp->Name } = $comp; + push @{$clist->Array}, $comp; + } + + # continue adding compartments (recursive) + if ( @_ ) + { return $clist->add(@_); } + else + { return ''; } +} + + + + +sub toString +{ + my $clist = shift; + my $plist = (@_) ? shift : undef; + + my $string = "begin compartments\n"; + foreach my $comp (@{$clist->Array}){ + $string .= ' ' . $comp->toString($plist) . "\n"; + } + $string .= "end compartments\n"; + + return $string; +} + + + + +sub readString +# $err = $clist->readString(compartment_string,param_list) +# Reads a single compartment specification from a string with the following format: +# name type volume [outside compartments] +# updates by justinshogg@gmail.com 17feb2009 +{ + my $clist = shift; # CompartmentList + my $string = shift; # compartment string to parse + my $plist = shift; # parameter list + + # Remove leading whitespace + $string =~ s/^\s*//; + + # Remove leading label, if any + if ($string =~ s/^\s*(\w+)\s*:\s+//) + { + # Check label for leading number + my $label = $1; + if ($label =~ /^\d/) { return "Syntax error (label begins with a number) at '$label'"; } + } + + # Read name (required argument), check for starting number + $string =~ s/^([A-Za-z_]\w*)// or return "Invalid compartment name in '$string' (must begin with a letter or underscore)"; + my $name = $1; + + # Read spatialDimensions (required argument) + $string =~ s/^\s*(\d+)// or return "Invalid Spatial Dimensions for Compartment in '$string'"; + my $spatialDimensions = $1; + # moved spatial dimension check to newCompartment sub in Compartment module + + # Read size expression (required argument, expression created on the fly) + my $size = Expression->new(); + $size->setAllowForward(1); + $size->readString(\$string, $plist) and return $_; + + # Read outside compartment (optional argument, but compartment must be in list if specified) + my $outside = undef; + if ( $string =~ s/^([A-Za-z_0-9]+)\s*// ) + { + my $cname = $1; + # Get compartment reference + $outside = $clist->Hash->{$cname} + || return("Outside compartment $cname is not in CompartmentList"); + } + + # check for extraneous arguments + if ( $string =~ /\S+/ ) + { return "Unrecognized trailing syntax in compartment specification"; } + + # create compartment + my ($comp, $err) = Compartment->newCompartment($name, $spatialDimensions, $size, $outside); + return $err if ($err); + + # add compartment to list + return $clist->add($comp); +} + + + + +sub toXML +{ + my $clist = shift; + my $indent = shift; + my $plist = (@_) ? shift : undef; + + my $string = $indent."\n"; + + foreach my $comp (@{$clist->Array}){ + $string .= $comp->toXML(" ".$indent, $plist); + } + + $string .= $indent."\n"; + return $string; +} + + + + +sub validate +{ + my $clist = shift; + + foreach my $comp (@{$clist->Array}) + { + if ($comp->SpatialDimensions eq '') + { + my $err = sprintf "Compartment %s referred to but not defined", $comp->Name; + } + } + return ''; +} + +1; diff --git a/libvcell/vcell_install/bionetgen/Perl2/Component.pm b/libvcell/vcell_install/bionetgen/Perl2/Component.pm new file mode 100644 index 0000000..3259851 --- /dev/null +++ b/libvcell/vcell_install/bionetgen/Perl2/Component.pm @@ -0,0 +1,648 @@ +# $Id: Component.pm,v 1.10 2007/01/22 19:22:48 faeder Exp $ + +package Component; + +# pragmas +use strict; +use warnings; + +# Perl Modules +use Class::Struct; +use FindBin; +use lib $FindBin::Bin; + +# BNG Modules +use BNGUtils; +use Compartment; + +# constants +use constant { TRUE => 1, + FALSE => 0 + }; + + +struct Component => { + Name => '$', + State => '$', + #Type => 'ComponentType', + Edges => '@', + Label => '$', + Compartment => 'Compartment' +}; + + + +### +### +### + + + +sub newComponent +{ + my $strptr = shift; + + my $comp = Component->new(); + my $err = $comp->readString($strptr); + + return ($comp, $err); +} + + + +### +### +### + + + +sub readString +{ + my $comp = shift @_; + my $strptr = shift @_; + my $clist = @_ ? shift @_ : undef; + + my $string_left = $$strptr; + + # Get component name (cannot start with a number) + if ( $string_left =~ s/^([A-Za-z_]\w*)// ) + { + $comp->Name($1); + } + else + { + return undef, "Invalid component name in '$string_left' (must begin with a letter or underscore)."; + } + + # Get component state (marked by ~) edges (marked by !) and label (marked by %) + my $edge_wildcard = 0; + my $edge_labels = 0; + while ($string_left) + { + if ( $string_left =~ s/^([~%!@])(\w+|\+|\?)// ) + { + my $type = $1; + my $arg = $2; + if ($type eq '~') + { + # State label + if (defined $comp->State) + { return undef, "Multiple state definitions"; } + $comp->State($arg); + } + elsif ($type eq '!') + { + # Bond label or wildcard + if ( $arg =~ /^[+?]$/ ) + { + if ($edge_wildcard or $edge_labels) + { return undef, "Multiple edge wildcards in component"; } + $edge_wildcard=1; + } + else + { + if ($edge_wildcard) + { return undef, "Labeled edges mixed with wildcard"; } + } + push @{$comp->Edges}, $arg; + } + elsif ($type eq '%') + { + # Tag label + if (defined $comp->Label) + { return undef, "Multiple label definitions"; } + $comp->Label($arg); + } + elsif ($type eq '@') + { + # Compartment label + if (defined $comp->Compartment) + { return undef, "Multiple compartment definitions"; } + + if ( defined $clist ) + { + if ( my $compart = $clist->lookup($arg) ) + { $comp->Compartment($compart); } + } + else + { + return undef, "Undefined compartment $arg"; + } + } + } + elsif ( $string_left =~ /^[,)]/ ) + { # Terminator characters for component + last; + } + else + { return undef, "Invalid syntax at $string_left"; } + } + + $$strptr = $string_left; + return ''; +} + + + +### +### +### + + + +sub toString +{ + my $comp = shift @_; + my $print_edges = @_ ? shift @_ : TRUE; + my $print_attributes = @_ ? shift @_ : TRUE; + + my $string .= $comp->Name; + + if (defined $comp->State ) + { $string .= sprintf "~%s", $comp->State; } + + if ($print_attributes) + { $string .= sprintf("%%%s", $comp->Label) if (defined $comp->Label); } + + if ( defined $comp->Compartment ) + { $string .= sprintf "@%s", $comp->Compartment->Name; } + + if (defined $comp->Edges ) + { + if ($print_edges) + { + my $wildcard=''; + foreach my $edge (@{$comp->Edges}) + { + if ($edge=~ /^\d+$/) + { $string .= sprintf "!%d", $edge+1; } + else + { $wildcard = "!$edge"; } + } + $string .= $wildcard; + } + else + { $string .= "!" x @{$comp->Edges}; } + } + + return $string; +} + +sub toSBMLMultiSpeciesTypeString +{ + my $comp = shift @_; + my $attributesString = ''; + my $bondsString = ''; + # if (defined $comp->State ) + # { + # $attributesString .= " "; + # #$attributesString .= sprintf "~%s", $comp->State; + # } + if (defined $comp->Edges ) + { + foreach my $edge (@{$comp->Edges}) + { + if ($edge=~ /^\d+$/) + { $bondsString .= sprintf "!%d", $edge+1; } + else + { + # we dont care about wildcards for sbml multi species types + return ''; + } + } + } + + # we might have to do something about multiplebonds/states + my $tailStr = $attributesString . $bondsString; + if($tailStr eq ''){ + return '' + } + else{ + return $comp->Name . $attributesString . $bondsString; + } + +} + + + +### +### +### + + + +sub toStringSSC +{ + my $comp = shift @_; + my $comp_label = @_ ? shift @_: 0; + my $print_edges = @_ ? shift @_ : TRUE; + + my $string = $comp->Name; + if ( $comp_label != 0 ) { $string .= $comp_label; } # for checking components with same name + # if comp_label != 0 same component exists + + if (defined $comp->Label) + { printf STDERR "ERROR: SSC Does not implement Label \n"; } + + if (defined $comp->Compartment) + { printf STDERR "ERROR: Compartments not implemented \n"; } + + if (defined $comp->State) + { + $string.= sprintf "=\"%s\"", $comp->State; + if ($comp_label ==0 ) + { # just appends Binds, as SSC doesnt allow states to bind + $string .= ", " . $comp->Name . "Binds"; + } + else + { + $string .= ", " . $comp->Name . $comp_label ."Binds"; + } + } + + if (defined $comp->Edges) + { + $string .= "#"; #As SSC considers every non-bound component as empty, so attaching # + if ($print_edges) + { + my $wildcard=""; + foreach my $edge (@{$comp->Edges}) + { + if ($edge=~ /^\d+$/) + { + $string.= sprintf "%d", $edge+1; + } + else + { + $wildcard="$edge"; + } + $string.=$wildcard; + } + } + else + { + $string.= ""x scalar(@{$comp->Edges}); + } + } + $string =~ s/\+/_/; # SSC equivalent of '+' is '_', substituting that + return $string; +} + + + + + +######## +# returns information for the outwardBindingSite belonging to species in sbml multi +###### +sub getSBMLMultiOutwardBonds +{ + my $comp = shift @_; + my $indent = shift @_; + my $mName = shift @_; + my $index = shift @_; + my $componentList_ref = shift @_; + my $multiComponentHash_ref = shift @_; + + my $string = ""; + my $fullstring = sprintf("%s(%s)",$mName, $comp->Name); + my $externalId = $componentList_ref->{$fullstring}[0]; + splice(@{$componentList_ref->{$fullstring}}, 0, 1); + my @indexArray = split(/_/, $index); + + # Attributes + # id + + # NumberOfBonds + my $nbonds = 0; + my $bindingstatus = ''; + foreach my $edge (@{$comp->Edges}) + { + if ($edge=~ /^[?]$/) + { + $bindingstatus = "either"; + } + elsif ($edge=~ /^[+]$/) + { + $bindingstatus = "bound"; + } + + else + { + ++$nbonds; + } + } + + if ($nbonds == 0 && $bindingstatus eq '') + { + $bindingstatus = "unbound"; + } + + if($nbonds > 1 ) + { + print "Can't handle components with more than one bond, skipping\n"; + return ""; + #sbml multi cant handle components with more than one bond. we should somehow return an error + } + + if (! $bindingstatus eq "" ) + { + #get a component from the component pool + my $reverseReference = $multiComponentHash_ref->{'reverseReferences'}->{$fullstring}[0]; + my $indent2 = ' ' . $indent; + #get a speciestype id based on that component + if(defined $reverseReference){ + my $externalComponentId = $multiComponentHash_ref->{'Components'}->{$reverseReference}{'id'}; + #my @splitArray = split(/_/, $reverseReference); + #my $externalComponentId = sprintf("cmp_%s_M%d_C%d", $splitArray[0], substr($indexArray[1], 1), substr($indexArray[2], 1)); + + #we used this component so remove it from the pool + splice(@{$multiComponentHash_ref->{'reverseReferences'}->{$fullstring}}, 0, 1); + + + $string = $indent2 . sprintf("\n", $bindingstatus, $externalComponentId); + } + else{ + $string = $indent2 . sprintf("\n", $bindingstatus, $externalId); + } + # Objects contained + } + return $string; +} + +#### +# returns a string containg the speciesfeature properties associated with this compartment +# for construction of a sbml species object in an sbml-multi file +##### +sub getSBMLMultiSpeciesFeature +{ + my $comp = shift @_; + my $indent = shift @_; + my $mName = shift @_; + my $index = shift @_; + my $componentList_ref = shift @_; + # list of references to sbml multi species type objects for this species + my $multiComponentHash_ref = shift @_; + my $string = ""; + + my @indexArray = split(/_/, $index); + # state + if (defined $comp->State) + { + my $fullstring = sprintf("%s(%s~", $mName, $comp->Name). ${comp}->State . ")"; + my $partialtring = sprintf("%s(%s~", $mName, $comp->Name); + #my $fullstring = sprintf("%s(%s~%s)",$mName, $comp->Name, $comp->State); + #calculate external id + + #get a component from the component queue + my $reverseReference = $multiComponentHash_ref->{'reverseReferences'}->{$partialtring}[0]; + my $externalComponentId; + + my $externalId = $componentList_ref->{$fullstring}[0]; + splice(@{$componentList_ref->{$fullstring}}, 0, 1); + my $indent2 = ' ' . $indent; + + if(defined $reverseReference){ + my @splitArray = split(/_/, $reverseReference); + # get the species type id associated with this top level component + if(exists $multiComponentHash_ref->{'Components'}->{$reverseReference}{'id'}){ + #FIXME: the species graph signature may not match between species type and spcies, which makes this matching obsolete + $externalComponentId = sprintf("cmp_%s_M%d_C%d", $splitArray[0], substr($indexArray[1], 1), substr($indexArray[2], 1)); + #$externalComponentId = $multiComponentHash_ref->{'Components'}->{$reverseReference}{'id'}; + } + else{ + # if its a state-only component it doesnt have a explicit speciestype reference so we refer to its parent molecule instead + # we do it a little hack~ish here by manipulating the $reverseReference id to point to the molecule id instaed + # this expects an id that follows the sid_mid_cid convention + + + #$splitArray[0] ="cmp_" . $splitArray[0]; + #$externalComponentId = join('_', @splitArray[0..$#splitArray-1]); + + $externalComponentId = sprintf("cmp_%s_M%d", $splitArray[0], substr($indexArray[1], 1)); + + + } + #regardless we used up this component hash reference so pop it to flag its been used + splice(@{$multiComponentHash_ref->{'reverseReferences'}->{$partialtring}}, 0, 1); + #get an id to the species type associated component based on the reverse reference + + $string = $indent2 . sprintf("\n",$index, $externalId, 1, $externalComponentId); + + } + else{ + $string = $indent2 . sprintf("\n",$index, $externalId, 1); + } + + my $indent3 = " " . $indent2; + # Objects contained + my $stateDefStr = $indent3 . "\n"; + $stateDefStr = $stateDefStr. $indent3 . " " . sprintf("\n",$externalId ."_" .$comp->State); + $stateDefStr = $stateDefStr. $indent3 . "\n"; + + $string = $string . $stateDefStr; + $string = $string . $indent2 . "\n"; + } + + # Attributes + # id + + return $string; +} + + +### +### +### +sub toXML +{ + my $comp = shift @_; + my $indent = shift @_; + my $id = shift @_; + my $index = (@_) ? shift @_ : ''; + + my $string = $indent . "Name . "\""; + # state + if (defined $comp->State) + { + $string .= " state=\"" . $comp->State . "\""; + } + if (defined $comp->Label) + { + $string .= " label=\"" . $comp->Label . "\""; + } + if ($comp->Compartment) + { + $string .= " compartment=\"" . $comp->Compartment->Name . "\""; + } + + # NumberOfBonds + my $nbonds = 0; + my $wildcard = ''; + foreach my $edge (@{$comp->Edges}) + { + if ($edge=~ /^[?+]$/) + { + $wildcard = $edge; + } + else + { + ++$nbonds; + } + } + if ($wildcard) + { + $nbonds = ($nbonds>0) ? $nbonds.$wildcard : $wildcard; + } + $string .= " numberOfBonds=\"" . $nbonds . "\""; + + # Objects contained + my $indent2 = ' ' . $indent; + my $ostring = ''; + + # Termination + if ($ostring) + { # terminate tag opening + $string .= ">\n"; + $string .= $ostring; + $string .= $indent . "\n"; + } + else + { # short tag termination + $string .= "/>\n"; + } + + return $string; +} + + + +### +### +### + + + +# Make an exact copy of a component. +sub copy +{ + # get component that we want to copy + my $comp = shift @_; + # should we copy labels? + my $copy_labels = (@_) ? shift @_ : 1; + # prefix for edge names? + my $prefix = (@_) ? shift @_ : ''; + + # create a new component + my $comp_copy = Component->new(); + + # copy scalar attributes + $comp_copy->Name( $comp->Name ); + $comp_copy->Label( $comp->Label ) if ($copy_labels); + $comp_copy->State( $comp->State ); + $comp_copy->Compartment( $comp->Compartment ) if (defined $comp->Compartment); + + # copy edges + if ( @{$comp->Edges} ) + { + # add prefix to edge label, unless its a wildcard + $comp_copy->Edges( [map {$_=~/^[*+?]$/ ? $_ : $prefix.$_} @{$comp->Edges}] ); + } + + # return the copy component + return $comp_copy; +} + + + +### +### +### + + + +# call this method to link Compartments to a new CompartmentList +sub relinkCompartments +{ + my $comp = shift @_; + my $clist = shift @_; + + my $err; + unless ( ref $clist eq 'CompartmentList' ) + { return "Component->relinkCompartments: Error!! Method called without CompartmentList object"; } + + if ( defined $comp->Compartment ) + { + my $new_compart = $clist->lookup( $comp->Compartment->Name ); + unless ($new_compart) + { return "Molecule->relinkCompartments: Error!! could not find compartment name in list"; } + $comp->Compartment( $new_compart ); + } + + return undef; +} + + + +### +### +### + + + +# Component comparison for isomorphism +sub compare_local +{ + my $a = shift; + my $b = shift; + + my $cmp; + # Component name + if ( $cmp = ($a->Name cmp $b->Name) ) + { return $cmp; } + + # Component state + if ( defined $a->State ) + { + unless (defined $a->State) { return 1; } + if ( $cmp = ($a->State cmp $b->State) ) + { return $cmp; } + } + elsif ( defined $b->State ) + { + return -1; + } + + # Component compartment + if ( defined $a->Compartment ) + { + unless (defined $b->Compartment) { return 1; } + if ( $cmp = ($a->Compartment <=> $b->Compartment) ) + { return $cmp; } + } + elsif ( defined $b->Compartment ) + { + return -1; + } + + # Number of edges + if ( $cmp = (@{$a->Edges} <=> @{$b->Edges}) ) + { return $cmp; } + + return 0; +} + + + +### +### +### + +1; diff --git a/libvcell/vcell_install/bionetgen/Perl2/ComponentType.pm b/libvcell/vcell_install/bionetgen/Perl2/ComponentType.pm new file mode 100644 index 0000000..59680e2 --- /dev/null +++ b/libvcell/vcell_install/bionetgen/Perl2/ComponentType.pm @@ -0,0 +1,261 @@ +# $Id: ComponentType.pm,v 1.3 2006/05/01 03:32:43 faeder Exp $ + +# Objects for typing and checking Components of Molecules +package ComponentType; + +use Class::Struct; +use FindBin; +use lib $FindBin::Bin; +#use List::MoreUtils qw(first_index); + + +#copied from list::moreutils since it doesnt come standard +sub first_index (&@) { + my $f = shift; + foreach my $i ( 0 .. $#_ ) { + local *_ = \$_[$i]; + return $i if $f->(); + } + return -1; +} + + +struct ComponentType=> { + Name=> '$', + States=> '@', # First element of States array is the default state, which + # is used in creating new molecules that don't have user-specified + # state attributes. + Edges=> '@', # Last two are not currently used in checking + Compartments=> '@' +}; +sub readString{ + my $ctype= shift; + my $strptr= shift; + + my $string_left=$$strptr; + + # Get component name (cannot start with a number) + if ( $string_left =~ s/^([A-Za-z_]\w*)// ) + { + $ctype->Name($1); + } + else + { + return undef, "Invalid component name in '$string_left' (must begin with a letter or underscore)."; + } + + # Get component state (marked by ~) edges (marked by !) + my @states=(); + my @compartments=(); + my @elabels=(); + while ($string_left){ + if ($string_left=~ s/^([~!@])([A-Za-z0-9_]+)//){ + my $type=$1; + my $arg=$2; + if ($type eq '~'){ + push @states, $arg; + } + elsif ($type eq '!'){ + push @elabels, $arg; + } + elsif ($type eq '@'){ + push @compartments, $arg; + } + } + elsif ($string_left=~ /^[,)]/){ # Terminator characters for component + last; + } + else { + return("Invalid syntax at $string_left"); + } + } + + if (@states){ + $ctype->States([@states]); + } + if (@elabels){ + $ctype->Edges([@elabels]); + } + if (@compartments){ + $ctype->Compartments([@compartments]); + } + + $$strptr= $string_left; + return(""); +} + + +sub copy +{ + my $comp = shift; + + my $comp_copy = ComponentType::new(); + $comp_copy->Name( $comp->Name ); + $comp_copy->States( [@{$comp->States}] ); + $comp_copy->Edges( [@{$comp->Edges}] ); + $comp_copy->Compartments( [@{$comp->Compartments}] ); + + return $comp_copy; +} + +sub toString{ + my $ctype= shift; + my $string=""; + + $string.= $ctype->Name; + for my $state (@{$ctype->States}){ + $string.= "~$state"; + } + return($string); +} + +sub toStringSSC{ + my $ctype= shift; + my $string=""; + $string.= $ctype->Name; + $string .= "#"; + for my $state (@{$ctype->States}){ + $string.= "=\"$state\""; + } + return($string); +} + +##### +# information used to create speciestype object in sbml multi +##### +sub toSBMLMultiSpeciesTypeFeatures +{ + my $ctype = shift @_; + my $cid = shift @_; + my $mName = shift @_; + my $sbmlMultiSpeciesInfo_ref = shift @_; + my $speciesIdHash_ref = shift @_; + my $indent = shift @_; + + my $ostring = ''; + my $ststring = ''; + + #this parameter should eventually be sent from outside for symmetric components + my $occur = 1; + my $fullname = ''; + if (@{$ctype->States}){ + + my $indent2 = " ".$indent; + my $indent3 = " ".$indent2; + my $sid = ''; + + + $ostring.= sprintf("%s\n", $indent, $cid, $ctype->Name, $occur); + $ostring.= $indent2."\n"; + my $exists; + for my $state (@{$ctype->States}){ + $fullname = sprintf("%s(%s~", $mName, $ctype->Name). "${state})"; + $exists = first_index {$_ eq $cid } @{$speciesIdHash_ref->{'Components'}{$fullname}}; + if ($exists == -1){ + push @{$speciesIdHash_ref->{'Components'}{$fullname}}, $cid; + } + $sid = sprintf("%s_%s",$cid, $state); + $ostring .= sprintf("%s\n",$indent3, $sid, $state); + } + $ostring.= $indent2."\n"; + $ostring.= $indent . "\n"; + } + return $ostring; +} + +sub toSBMLMultiSpeciesTypeBinding +{ + my $ctype = shift @_; + my $cid = shift @_; + my $mName = shift @_; + my $sbmlMultiSpeciesInfo_ref = shift @_; + my $speciesIdHash_ref = shift @_; + my $indent = shift @_; + + my $ostring = ''; + my $fullname = sprintf("%s(%s)", $mName, $ctype->Name); + $ostring .= sprintf("%s\n", $indent, $cid, $ctype->Name, $cid); + my $strstring; + + # pure binding site + if (!@{$ctype->States}){ + $ststring = sprintf("\n", $cid, $ctype->Name); + } + # this binding site also has states! + else{ + $ststring = sprintf("\n", $cid, $ctype->Name); + my $featuretypes .= $ctype->toSBMLMultiSpeciesTypeFeatures($cid."_ft",$mName,$sbmlMultiSpeciesInfo_ref,$speciesIdHash_ref,$indent); + + if(! $featuretypes eq ''){ + $ststring .= $indent. "\n"; + $ststring .= $featuretypes; + $ststring .= $indent. "\n"; + + } + $ststring .= $indent. "\n"; + } + my $exists = first_index {$_ eq $cid } @{$speciesIdHash_ref->{'Components'}{$fullname}}; + if ($exists == -1){ + push @{$speciesIdHash_ref->{'Components'}{$fullname}}, $cid; + } + push @{$sbmlMultiSpeciesInfo_ref->{$cid}}, $cid; + push @{$sbmlMultiSpeciesInfo_ref->{$cid}}, $ststring; + + + return $ostring; +} + + +##### +##### +##### +##### + +sub toXML{ + my $ctype= shift; + my $indent= shift; + my $string=$indent."Name."\""; + + # Objects + my $indent2= " ".$indent; + my $ostring=""; + if (@{$ctype->States}){ + $ostring.= $indent2."\n"; + for my $state (@{$ctype->States}){ + $ostring.=$indent2." \n"; + } + + if ($ostring){ + $string.=">\n"; + $string.=$ostring; + $string.=$indent."\n"; + } else { + $string.="/>\n"; + } + + return($string); +} + +sub writeMDL +{ + my $ctype = shift; + my $string = $ctype->Name; + + if (@{$ctype->States}){ + foreach my $state (@{$ctype->States}){ + $string .= "~".$state; + } + } + return $string; +} + + +1; diff --git a/libvcell/vcell_install/bionetgen/Perl2/Console.pm b/libvcell/vcell_install/bionetgen/Perl2/Console.pm new file mode 100644 index 0000000..b3c0337 --- /dev/null +++ b/libvcell/vcell_install/bionetgen/Perl2/Console.pm @@ -0,0 +1,239 @@ +# This package contains routines for running BNG as an interactive console +package Console; + +# pragmas +use strict; +use warnings; + +# Perl Modules +use FindBin; +use lib $FindBin::Bin; +use File::Spec; + +require Exporter; +our @ISA = qw( Exporter ); +our @EXPORT = qw( BNGconsole ); + +# BNG Modules +use BNGUtils; +use BNGModel; + + + +# global variables +my $BNG_PROMPT = 'BNG> '; + + +sub BNGconsole +{ # take actions from interactive console! + my $params = (@_) ? shift : {}; + + # TODO: + # + differentiate between STDIN from console and file? + # + add more model query commands + + + # Am I interacting with a user, or a pipeline? + my $interactive = ( -t STDIN ) ? 1 : 0; + + # turn off output buffering on STDOUT + select STDOUT; $| = 1; + + # say hello! + printf "BioNetGen version %s\n", BNGversion(); + print "Entering BNG console mode.\n"; + print $BNG_PROMPT; + + # model begins as undefined + my $model = undef; + + # read input + while ( my $linein = ) + { + unless ($interactive) { print $linein; } + + + # trim leading and trailing white space + $linein =~ s/^\s+//; + $linein =~ s/\s+$//; + + PROCESS_INPUT: + { + # READ a model + if ( $linein =~ s/^load\s+// ) + { + if (defined $model) + { + send_warning( "Attempted to load model while another model is active." ); + last PROCESS_INPUT; + } + + # get filename +# $linein =~ s/^(\S+)\s*//; +# my $filename = $1; + + my $filename = $linein; + if ($filename =~ m/.*--.*/) { + $filename =~ s/^(.*?)(--.*)//; + $linein = $2; + $filename = $1; + } else { + $linein = ""; + } + $filename =~ s/^\s+//; $filename =~ s/\s+$//; + + unless ($filename and -e $filename) + { + send_warning( "Attempted to load model, but file '$filename' was not found." ); + last PROCESS_INPUT; + } + + # initialize parameters + my $local_params = { %$params }; + # add filename to params + $local_params->{file} = $filename; + + # process long args ('atomize' and 'blocks') + while ( $linein ){ + my ($key, $val); + # --atomize INT + if ( $linein =~ s/\s*--(\w+)\s+(\w+)// ){ + $key = $1; + $val = $2; + } + # --blocks ["STRING", "STRING", ...] + elsif( $linein =~ s/\s*--(\w+)\s+\[(.+)\]// ){ + $key = $1; + $val = [ split( '\s*,\s*', $2 ) ]; + foreach my $v (@$val){ + $v = eval $v; # need to evaluate each entry to a string + } + } + else{ + send_warning( "Error processing command line arguments: " . $linein ); + last PROCESS_INPUT; + } + $local_params->{$key} = $val; + } + + # create BNGModel object + $model = BNGModel->new(); + $model->initialize(); + $BNGModel::GLOBAL_MODEL = $model; + { # read model file + my $err = $model->readFile($local_params); + if ($err) + { # undefine model and send warning + %$model = (); undef %$model; $model = undef; + $BNGModel::GLOBAL_MODEL = undef; + send_warning( "Some problem processing '$filename': $err" ); + last PROCESS_INPUT; + } + } + } + + # EXECUTE an action + elsif ( $linein =~ s/^action\s+// ) + { + unless (defined $model) + { + send_warning( "Attempt to execute action without loading model." ); + last PROCESS_INPUT; + } + + my ($action, $options); + if ( $linein =~ /^\s*(\w+)\s*\((.*)\);?\s*$/ ) + { # syntax: "action(options)" + $action = $1; + $options = $2; + } + else + { + send_warning( "Invalid action syntax. Try: action actionName(options)." ); + last PROCESS_INPUT; + } + + # define action + my $command = '$model->' . $action . '(' . $options . ');'; + print "Begin action $action\n"; + + # Perform self-consistency checks before operations are performed on model + { + my $err = $model->ParamList->check(); + if ($err) + { + send_warning( "Problem executing action: paramlist failed consistency check." ); + last PROCESS_INPUT; + } + } + + # execute action + my $t_start = cpu_time(0); + { + my $err = eval $command; + if ($@) + { + send_warning("Problem executing action: $@."); + last PROCESS_INPUT; + } + if ($err) + { + send_warning("Problem executing action: $err."); + last PROCESS_INPUT; + } + my $t_elapsed = cpu_time($t_start); + printf "CPU TIME: %s %.2f s.\n", $action, $t_elapsed; + } + } + + # CLEAR model + elsif ( $linein =~ m/clear/ ) + { + unless (defined $model) + { + send_warning( "Attempt to clear model without loaded model." ); + last PROCESS_INPUT; + } + # undefine model + %$model = (); + undef %$model; + $model = undef; + $BNGModel::GLOBAL_MODEL = undef; + } + + # DONE + elsif ( $linein =~ m/done/ ) + { + undef $model; + print "Leaving BNG console.\n"; + exit(0); + } + + elsif ( $linein =~ m/help/ ) + { + print "HELP menu for BNG console\n"; + print "/-----------------------------------------------\n"; + print " load MODEL [OPTS] : load a BNG model file \n"; + print " done : leave BNG console \n"; + print " clear : clear BNG model \n"; + print " action ACTION : execute ACTION on loaded model\n"; + print "\n"; + print " OPTS:\n"; + print " --atomize INT\n"; + print " --blocks [\"STRING\", \"STRING\", ...]\n"; + print "-----------------------------------------------/\n"; + } + + # unrecognized command + else + { + send_warning( "Unrecognized input. Type 'help' for information" ); + } + } + + print $BNG_PROMPT; + } + + # stdin close + return 0; +} diff --git a/libvcell/vcell_install/bionetgen/Perl2/EnergyPattern.pm b/libvcell/vcell_install/bionetgen/Perl2/EnergyPattern.pm new file mode 100644 index 0000000..b9941f7 --- /dev/null +++ b/libvcell/vcell_install/bionetgen/Perl2/EnergyPattern.pm @@ -0,0 +1,262 @@ +package EnergyPattern; +# This class defines an energy pattern which contributes to the overall +# energy of a Species and influences reaction rates. --Justin + +# pragmas +use strict; +use warnings; +no warnings 'redefine'; + +# Perl Modules +use Class::Struct; +use FindBin; +use lib $FindBin::Bin; + +# BNG Modules +use BNGUtils; +use BNGModel; +use SpeciesGraph; + + + +struct EnergyPattern => +{ + Pattern => 'SpeciesGraph', # pattern graph + Gf => 'Expression', # free-energy parameter (per match) + Weights => '@' # number of matches to each species +}; + + +### +### +### + + +sub readString +{ + my ($epatt, $string, $model) = @_; + + my $err; + + # strip any leading whitesace + $string =~ s/^\s+//; + + # Check if first token is an index (This index will be ignored) + # DEPRECATED as of BNG 2.2.6 + if($string =~ s/^\s*\d+\s+//) + { + return "Leading index detected at '$string'. This is deprecated as of BNG 2.2.6."; + } + + # Remove leading label, if exists + if ($string =~ s/^\s*(\w+)\s*:\s+//) + { + # Check label for leading number + my $label = $1; + if ($label =~ /^\d/) { return "Syntax error (label begins with a number) at '$label'"; } + } + + # Check name for leading number + my $string_left = $string; + unless ( $string_left =~ s/^([A-Za-z_]\w*)// ) + { + return "Syntax error (pattern name begins with a number) at $string."; + } + + # Next read the SpeciesGraph that will define the Energy Pattern + my $sep = '^\s+'; + my $sg = SpeciesGraph->new(); + $err = $sg->readString( \$string, $model->CompartmentList, 0, $sep, $model->MoleculeTypesList, 1 ); + if ($err) { return "While reading Energy Pattern: $err"; } + + $epatt->Pattern($sg); + + # Look for free-energy of formation expression (Gf) + # and construct equillibrium factor + my $Gf_expr = Expression->new(); + if ( $string =~ /\S+/ ) + { + # Read expression + $err = $Gf_expr->readString( \$string, $model->ParamList ); + if ($err) { return undef, $err; } + } + else + { + $err = sprintf "Missing free-energy token for energy pattern %s", $epatt->Pattern->toString(); + return $err; + } + # set Keq expression + $epatt->Gf($Gf_expr); + + # set Weights and RxnStoich to empty array + $epatt->Weights([]); + + # return with error (if defined) + return $err; +} + + + +sub toString +{ + my $epatt = shift; + my $plist = (@_) ? shift : undef; + my $string = ''; + + $string .= $epatt->Pattern->toString() . " " + . $epatt->Gf->toString($plist); + + return $string; +} + + + +sub toMatlabString +{ + my $epatt = shift; + my $string = ''; + + # TODO + + return $string, ''; +} + + + +sub toMexString +{ + my $epatt = shift; + my $string = ''; + + # TODO + + return $string, ''; +} + + + +sub toXML +{ + my $epatt = shift; + my $plist = (@_) ? shift : ''; + my $indent = (@_) ? shift : ''; + my $index = shift; + my $indent2 = " " . $indent; + my $id = "EP" . $index; + my $pid = $id . "_P1"; + + my $string = $indent . 'Pattern->toString() . '" '; # pattern + $string .= 'expression="'; + $string .= $epatt->Gf->toString($plist) . '">' . "\n"; # expression + $string .= $epatt->Pattern->toXML($indent2,"Pattern",$pid,""); + + $string .= $indent . "\n"; + + return $string; +} + + + +sub toMathMLString +{ + my $epatt = shift; + my $string = ''; + + # TODO + + return $string, ''; +} + + +# reset the observable weights to zero +sub reset_weights +{ + my $epatt = shift @_; + my $alloc = @_ ? shift @_ : 0; + $epatt->Weights( [(0) x ($alloc+1)] ); +} + + + +sub update +{ + my $epatt = shift @_; + my $species = shift @_; + my $idx_start = @_ ? shift @_ : 0; + + my $err = undef; + for ( my $ii = $idx_start; $ii < @$species; ++$ii ) + { + my $spec = $species->[$ii]; + next if ($spec->ObservablesApplied); + my @matches = $epatt->Pattern->isomorphicToSubgraph($spec->SpeciesGraph); + $epatt->Weights->[$spec->Index] = (scalar @matches)/($epatt->Pattern->Automorphisms); + } + return $err; +} + + + +sub getStoich +# returns an integer value corresponding to the stoichiometry of +# this pattern w.r.t. a given reaction. +{ + my ($epatt, $rxn) = @_; + + my $err; + my $stoich = 0; + foreach my $reactant (@{$rxn->Reactants}) + { + if ( $epatt->Weights->[$reactant->Index] ) + { $stoich -= $epatt->Weights->[$reactant->Index]; } + } + foreach my $product (@{$rxn->Products}) + { + if ( $epatt->Weights->[$product->Index] ) + { $stoich += $epatt->Weights->[$product->Index]; } + } + return $stoich, $err; +} + + + +sub getDeltaEnergy +{ + my ($epatt, $rxn, $plist) = @_; + + my $err; + my $stoich; + + # get stoichiometry of this pattern w.r.t. this rxn + ($stoich, $err) = $epatt->getStoich($rxn); + if ( $err ) { return undef, $err; } + + # construct a rate constant expression + my $rate_expr = undef; + if ( $stoich!=0 ) + { + if ( $stoich == 1 ) + { + $rate_expr = $epatt->Gf; + } + elsif ( $stoich == -1 ) + { + $rate_expr = Expression::operate("-", [$epatt->Gf], $plist); + } + else + { + $rate_expr = Expression::operate("*", [$stoich, $epatt->Gf], $plist); + } + } + + return $rate_expr, $err; +} + +### +### +### + +1; diff --git a/libvcell/vcell_install/bionetgen/Perl2/Expression.pm b/libvcell/vcell_install/bionetgen/Perl2/Expression.pm new file mode 100644 index 0000000..f6884c0 --- /dev/null +++ b/libvcell/vcell_install/bionetgen/Perl2/Expression.pm @@ -0,0 +1,2240 @@ +# $Id: Expression.pm,v 1.7 2007/02/20 17:39:38 faeder Exp $ + +# updated by msneddon, 2009/11/04 +# -added if statement as built in function +# -added binary logical operators, <,>.<=,>=,==,!=,~=,&&,|| +# to the basic functional parser, the toString function, and +# to the evaluate function + +# -todo: add binary operators to method toMathMLString function +# -todo: add the unary operator not: '!' (this is implemented, but not tested. --JSH) + +package Expression; + +# pragmas +use strict; +use warnings; +no warnings 'redefine'; +no warnings 'recursion'; + +# Perl Modules +use Class::Struct; +use FindBin; +use lib $FindBin::Bin; +use Scalar::Util ("looks_like_number"); + +# BNG Modules +use Param; +use ParamList; + +#use POSIX qw/floor ceil/; # safer to use 'floor' and 'ceil' instead of 'int' +use POSIX qw/floor/; # 'floor' and 'ceil' not supported by muParser. Use 'floor' for 'rint'. +use Math::Trig qw(tan asin acos atan sinh cosh tanh asinh acosh atanh pi); +use List::Util qw(min max sum); + +struct Expression => +{ + Type => '$', # Valid types are 'NUM', 'VAR', 'FunctionCall', '+', '-', '*', '/', '^', '**', + # '>','<','>=','<=','==','!=','~=','&&','||','!','~' + Arglist => '@', + Err => '$', + # AS-2021 + tfunFile => '$', + ctrName => '$', + # AS-2021 +}; + + +# NOTE: it's weird that some built-in functions with names (like exp, cos, etc) are handled +# differently than built-ins with operator symbols (like +, -, etc). We could really simplify this. +# --Justin +# Supported most muParser built-in functions. --LAH +# See http://muparser.sourceforge.net/mup_features.html#idDef2 for the complete list. +my %functions = +( + "_pi" => { FPTR => sub { pi }, NARGS => 0 }, # + "_e" => { FPTR => sub { exp(1) }, NARGS => 0 }, # (MathML 2.0) + "time" => { FPTR => sub + { + if (defined($BNGModel::GLOBAL_MODEL->time)) + {$BNGModel::GLOBAL_MODEL->time} + else {0} + }, NARGS => 0 }, # ??? + "exp" => { FPTR => sub { exp( $_[0] ) }, NARGS => 1 }, # (MathML 2.0) + "ln" => { FPTR => sub { log( $_[0] ) }, NARGS => 1 }, # + "log10" => { FPTR => sub { log($_[0])/log(10) }, NARGS => 1 }, # + "log2" => { FPTR => sub { log($_[0])/log(2) }, NARGS => 1 }, # 2 + "abs" => { FPTR => sub { abs( $_[0] ) }, NARGS => 1 }, # +# "int" => { FPTR => sub { int( $_[0] ) }, NARGS => 1 }, # deprecated! +# "floor" => { FPTR => sub { floor( $_[0] ) }, NARGS => 1 }, # not supported by muParser +# "ceil" => { FPTR => sub { ceil( $_[0] ) }, NARGS => 1 }, # not supported by muParser + "rint" => { FPTR => sub { floor( $_[0] + 0.5 ) }, NARGS => 1 }, # requires special handling (see toMathMLString) + "sqrt" => { FPTR => sub { sqrt( $_[0] ) }, NARGS => 1 }, # + "cos" => { FPTR => sub { cos( $_[0] ) }, NARGS => 1 }, # + "sin" => { FPTR => sub { sin( $_[0] ) }, NARGS => 1 }, # + "tan" => { FPTR => sub { tan( $_[0] ) }, NARGS => 1 }, # + "asin" => { FPTR => sub { asin( $_[0] ) }, NARGS => 1 }, # + "acos" => { FPTR => sub { acos( $_[0] ) }, NARGS => 1 }, # + "atan" => { FPTR => sub { atan( $_[0] ) }, NARGS => 1 }, # + "sinh" => { FPTR => sub { sinh( $_[0] ) }, NARGS => 1 }, # + "cosh" => { FPTR => sub { cosh( $_[0] ) }, NARGS => 1 }, # + "tanh" => { FPTR => sub { tanh( $_[0] ) }, NARGS => 1 }, # + "asinh" => { FPTR => sub { asinh( $_[0] ) }, NARGS => 1 }, # (MathML 2.0) + "acosh" => { FPTR => sub { acosh( $_[0] ) }, NARGS => 1 }, # (MathML 2.0) + "atanh" => { FPTR => sub { atanh( $_[0] ) }, NARGS => 1 }, # (MathML 2.0) + "if" => { FPTR => sub { if($_[0]) { $_[1] } else { $_[2] } }, NARGS => 3 }, # requires special handling (see toMathMLString) + "min" => { FPTR => sub { min(@_) }, NARGS => scalar(@_) }, # + "max" => { FPTR => sub { max(@_) }, NARGS => scalar(@_) }, # + "sum" => { FPTR => sub { sum(@_) }, NARGS => scalar(@_) }, # + "avg" => { FPTR => sub { sum(@_)/scalar(@_) }, NARGS => scalar(@_) }, # + "mratio" => { FPTR => sub { Mratio($_[0],$_[1],$_[2]) }, NARGS => 3 }, + "TFUN" => { FPTR => sub { TFUN($_[0], $_[1]) }, NARGS => 2 }, # AS-2021, function to load from file +); + +# AS-2021 TFUN stuff +sub TFUN +{ + # this function is supposed to indicate NFsim that it needs to + # load the file in the second argument. Then use the observable + # given by the first argument to compare to the first column given + # in the file and pull values from the second column. + my $obs = shift @_; + my $file = shift @_; + # for now, just return the obs value to keep the rest of the mechanism + # working. + print "You are trying to evaluate a TFUN function ಠ_ಠ TFUNs only make sense + within NFsim. Try using NFsim, I'm going to dissapear into the + ether now, good bye cruel world ◉︵◉ \n"; + exit 1; + # TODO: Figure out a behavior for this function for simulators outside + # of NFsim + # return $obs +} +# AS-2021 + +sub Mratio +{ + # Original Fortran code written by William Hlavacek (2018) + # Converted to Python and then Perl by Leonard A. Harris (2019) + my $a = shift @_; + my $b = shift @_; + my $z = shift @_; + # c This routine calculates the ratio M(a+1,b+1,z)/M(a,b,z) + # c as a continued fraction f in the class of Gauss's continued fraction + # c [Gauss CF (1813)] + # c using the modified method of Lentz WJ (1976) [Applied Optics 15:668-671] + # c [Thompson IJ, Barnett AR (1986) J Comput Phys 64: 490-509]. + # c M(a,b,z) = {}_1F_1(a;b;z) is Kummer's (confluent hypergeometric) function + # c [Kummer EE (1837) Crelle's Journal 17:228-242]. + # c In general, we take f to have the following form: + # c f = q_0 + \frac{p_1}{q_1 +} \frac{p_2}{q_2 +} \frac{p_3}{q_3 +} \cdots + # c For the ratio of interest, + # c p_1 = 1 + # c p_2 = z*[a-(b+0)]/[(b+0)*(b+1)] + # c p_3 = z*(a+1) /[(b+1)*(b+2)] + # c p_4 = z*[a-(b+1)]/[(b+2)*(b+3)] + # c p_5 = z*(a+2) /[(b+3)*(b+4)] + # c q_0 = 0 + # c q_j = 1 for j = 1, 2, ... + # c [Van Vleck EB (1901) Ann Math 3: 1-18]. + # implicit none + # c argument + # double precision a,b,z + # c parameter + # double precision eps,tiny + # parameter(eps=1.0d-16,tiny=1.0d-32) + my $eps = 1e-16; + my $tiny = 1e-32; + # c local + # integer j,iodd,ieven + # integer odd,oddsave,even,evensave + # double precision f,fsave,C,Csave,D,Dsave,err + # double precision p,q,num,den,Delta + # + # c initialize + # c In general, we set f_0 = q_0. + # c However, if q_0 = 0, we set f_0 = tiny instead. + # c We then set C_0 = f_0 and D_0 = 0. + my $fsave = $tiny; + my $Csave = $fsave; + my $Dsave = 0.0; + + # c We set err to a value greater than eps. + my $err = 1.0 + $eps; + + my $odd= 1; + my $even= 0; + my $iodd= 0; + my $ieven= 0; + my $j=0; + my $f; # return value + while($err > $eps){ + $j=$j+1; + my $p; + # c calculate p_j and q_j + # + # c p_1 = 1 + # c p_j = num_j/den_j for j = 2, 3, ... + # c den_j = [b+(j-2)]*[b+(j-1)] for j = 2, 3, ... + # c if j>1 is even, then num_j = z*[a-(b+(j-2)/2)] = z*(a-(b+ieven-1)) + # c if j>1 is odd, then num_j = z*[a+(j-1)/2] = z*(a+iodd) + if($j == 1){ + $p=1.0; + } + elsif($j > 1){ + my $den=($b+($j-2))*($b+($j-1)); + my $num; + if($odd == 1){ + $iodd=$iodd+1; + $num=$z*($a+$iodd); + } + elsif($even == 1){ + $ieven=$ieven+1; + $num=$z*($a-($b+($ieven-1))); + } + else{ + print "Error: iodd=$iodd, ieven=$ieven\n"; + exit 1; + } + $p=$num/$den; + } + else{ + print "Error: j=$j\n"; + exit 1; + } + + # c q_j = 1 for j = 1, 2, ... + my $q=1.0; + + # c calculate jth terms in recurrence relations + # c C_j = q_j + p_j/C_{j-1} + # c D_j = 1/(q_j + p_j*D_{j-1}) + my $D=$q+$p*$Dsave; + if(abs($D) < $tiny){ + $D=$tiny; + } + my $C=$q+$p/$Csave; + if(abs($C) < $tiny){ + $C=$tiny; + } + $D=1.0/$D; + + # c current approximation + # c f_j = C_j*D_j*f_{j-1} + my $Delta=$C*$D; + $f=$Delta*$fsave; + + # c if Delta is sufficiently close to 1, then the current approximation is acceptable. + $err=abs($Delta-1.0); + + # c prepare for next iteration + $fsave=$f; + $Csave=$C; + $Dsave=$D; + my $oddsave=$odd; + my $evensave=$even; + $odd=$evensave; + $even=$oddsave; + } + return $f; +} + +my $MAX_LEVEL = 500; # Prevent infinite loop due to dependency loops + +# this hash maps operators to the min and max number of arguments +my %NARGS = ( '+' => { 'min'=>2 }, # + '-' => { 'min'=>1 }, # + '*' => { 'min'=>2 }, # + '/' => { 'min'=>2 }, # + '^' => { 'min'=>2, 'max'=>2 }, # + '**' => { 'min'=>2, 'max'=>2 }, # Not supported by muParser + '&&' => { 'min'=>2 }, # + '||' => { 'min'=>2 }, # + '<' => { 'min'=>2, 'max'=>2 }, # + '>' => { 'min'=>2, 'max'=>2 }, # + '<=' => { 'min'=>2, 'max'=>2 }, # + '>=' => { 'min'=>2, 'max'=>2 }, # + '!=' => { 'min'=>2, 'max'=>2 }, # + '~=' => { 'min'=>2, 'max'=>2 }, # Not supported by muParser + '==' => { 'min'=>2, 'max'=>2 }, # (MathML 2.0) + '!' => { 'min'=>1, 'max'=>1 }, # Not supported by muParser + '~' => { 'min'=>1, 'max'=>1 } # Not supported by muParser + ); + +# muParser operators +# ------------------ +# + addition +# - subtraction +# * multiplication +# / division +# ^ raise x to the power of y +# && logical and +# || logical or +# < less than +# > greater than +# <= less or equal +# >= greater or equal +# != not equal +# == equal + + +# this regex matches param names (letter followed optional by word characters) +my $PARAM_REGEX = '^\w+$'; + + +### +### +### + +sub isBuiltIn +{ + my $name = shift @_; + return (exists $functions{$name} ? 1 : 0); +} + +### +### +### + + +# get a recursive copy of an expression. +# Note that the recursion does not descend past VAR and FunctionCall type expressions. +# Returns a reference to the clone and any error messages. +sub clone +{ + my $expr = shift; + my $plist = (@_) ? shift : undef; + my $level = (@_) ? shift : 0; + + if ( $level > $MAX_LEVEL ) { die "Max recursion depth $MAX_LEVEL exceeded."; } + + my $err = ''; + + # create a new array for cloned argument + my $clone_args = []; + # create clone + my $clone = Expression->new(); + $clone->Type( $expr->Type ); + $clone->Arglist( $clone_args ); + $clone->Err( '' ); + + # clone argument expressions + foreach my $arg ( @{$expr->Arglist} ) + { + my $clone_arg; + if ( ref $arg eq 'Expression' ) + { + # recursively expand expressions + my $clone_arg; + ($clone_arg, $err) = $arg->clone($plist,$level+1); + push @$clone_args, $clone_arg; + } + else + { + push @$clone_args, $arg; + } + } + + return ($clone, $err); +} + + +# TODO: simplify method +# eliminate 1's from mulitplications and divisions +# eliminate 0's from additions and subtractions. +# cancel terms in basic arthimetic operations. + + +### +### +### + + +# create a new expression from a number or a param name +sub newNumOrVar +{ + my $value = shift @_; + my $plist = (@_) ? shift @_ : undef; + + my $expr; + my $err; + # is this a number? + if ( looks_like_number($value) ) + { # create a new number expression + $expr = Expression->new(); + $expr->Type('NUM'); + $expr->Arglist( [$value] ); + $expr->Err( undef ); + } + # or possibly a parameter name? + elsif ( $value =~ /$PARAM_REGEX/ ) + { + # we need a paramlist to continue + if ( ref $plist eq "ParamList" ) + { + # check that parameter exists + (my $param, $err) = $plist->lookup( $value ); + if (defined $param) + { # create a new number expression + $expr = Expression->new(); + $expr->Type('VAR'); + $expr->Arglist( [$value] ); + $expr->Err( undef ); + } + } + } + + unless (defined $expr) + { die "Expression::newNumOrVar() - Attempted but failed to create number or variable expression"; } + + # return expression or undefined + return $expr; +} + + +### +### +### + + +# Creates a new expression from a list of existing expressions. +# The type argument indicates the operation used to combine the expressions. +# E.g. '+', '-', 'FunctionCall'. +# If the type is 'FunctionCall', then the first argument should be the name of +# a built-in or user-defined function. +sub operate +{ + my ($type, $args, $plist) = @_; + + # can't do anything without arguments! + unless (@$args) { return undef; } + + # operate is unhappy without a paramlist! + unless (ref $plist eq 'ParamList') { return undef; } + + my $err; + my $args_copy; + + # copy the arguments + @$args_copy = @$args; + + # Check for the right number of arguments.. + + # is this a function? + if ( $type eq 'FunctionCall' ) + { + # get function name (first argument) + my $fcn_name = $args_copy->[0]; + + # is this a built-in function? + if ( defined $fcn_name and exists $functions{$fcn_name} ) + { # correct number of arguments? + return undef unless ( $functions{$fcn_name}->{NARGS} == (@$args_copy - 1) ); + } + # or is this custom? + else + { + # lookup function in parameter list + (my $fcn_param, $err) = $plist->lookup( $fcn_name ); + if ( $err or !defined($fcn_param) ) { return undef; } + + if ( ref $fcn_param ne 'Param' or $fcn_param->Type ne 'Function' ) + { return undef; } + + # correct number of arguments? + unless ( @{$fcn_param->Ref->Args} == (@$args_copy - 1) ) + { return undef; } + } + + # clone arguments (not first argument, which is the fcn name) + foreach my $arg ( @$args_copy[1..$#$args_copy] ) + { + # clone argument, if it's an expression + if ( ref $arg eq 'Expression' ) + { ($arg, $err) = $arg->clone($plist); } + + # if arg isn't an expression, try to create one + else + { $arg = Expression::newNumOrVar( $arg ); } + + # check that are is still defined + unless (defined $arg) { return undef; } + } + } + # or an operator? + else + { + # check that the operator exists and has the right number of arguments + unless ( exists $NARGS{$type} ) + { return undef; } + if ( (exists $NARGS{$type}->{min}) and (($NARGS{$type}->{min}) > (@$args_copy)) ) + { return undef; } + if ( (exists $NARGS{$type}->{max}) and (($NARGS{$type}->{max}) < (@$args_copy)) ) + { return undef; } + + # clone arguments + foreach my $arg ( @$args_copy ) + { + # clone argument, if it's an expression + if ( ref $arg eq 'Expression' ) + { ($arg, $err) = $arg->clone($plist); } + + # if arg isn't an expression, try to create one + else + { $arg = Expression::newNumOrVar($arg,$plist); } + + # check that are is still defined + unless (defined $arg) { return undef; } + } + } + + # return undefined if there were any errors + if ($err) { return undef; } + + # create the new expression + my $expr = Expression->new(); + $expr->Type( $type ); + $expr->Arglist( $args_copy ); + $expr->Err( undef ); + + # return reference to expression! + return $expr; +} + + +### +### +### + + +# load an expression by parsing a string +{ + my $string_sav; + my $variables = {}; + my $allowForward = 0; + + + sub setAllowForward + { + my $expr = shift @_; + $allowForward = shift @_; + } + + + sub readString + { + # get arguments + my $expr = shift @_; + my $sptr = shift @_; + my $plist = @_ ? shift @_ : undef; + my $end_chars = @_ ? shift @_ : ''; + my $level = @_ ? shift @_ : 0; + + my $err = ''; + my $ops_bi = '\*\*|[+\-*/^]|>=|<=|[<>]|==|!=|~=|&&|\|\|'; + my $ops_un = '[+\-!~]'; + + if ( $level==0 ) + { + $string_sav = $$sptr; + %$variables = (); + } + + # AS-2021 + # my $fstr; + my $ctrName; + # Pre-parse expression for TFUNC to remove string argument + if ($$sptr =~ /TFUN\(.*\)/) + { + # check to see if we have one or two arguments + if ($$sptr =~ s/TFUN\(\s*([^\)\,]*)\s*,\s*[\'\"]\s*([^\)]*)\s*[\'\"]\s*\)/__TFUN__VAL__/) { + # two arguments, first one is observable, + # second is file + $ctrName = $1; + $expr->tfunFile($2); + # $fstr = $2; + $expr->ctrName($ctrName); + $$sptr =~ s/__TFUN__VAL__/TFUN\($ctrName\)/; + } + # else { + # print "I can't parse the arguments given to TFUN function: ".$$sptr."\n"; + # exit 1 + # } + # this is for single argument TFUN parsing, unhooking this for now + # elsif ($$sptr =~ s/TFUN\(\s*(.*)\s*\)/$1/) { + # # we have a single file argument + # $expr->ctrName($1); + # $fstr = $1; + # if ($fstr =~ s/(\".*\")//) { + # $expr->tfunFile($1); + # } elsif ($fstr =~ s/(\'.*\')//) { + # $expr->tfunFile($1); + # } else { + # print "I can't parse the file given to TFUN function: ".$fstr."\n"; + # exit 1 + # } + } + # AS-2021 + + # parse string into form expr op expr op ... + # a+b*(c+d) + # -5.0e+3/4 + my $last_read = ''; + my $expr_new = ''; + my @list = (); + my $expect_op = 0; + my $assign_var_name = ''; + while ( $$sptr ne '' ) + { + # OPERATORS + if ($expect_op) + { + # Binary operator + if ( $$sptr =~ s/^\s*($ops_bi)// ) + { + my $express = Expression->new( Type=>$1 ); + push @list, $express; + $expect_op = 0; + next; + } + + # Assignment using '='. Valid syntax is PARAM = EXPRESSION + # NOTE: this really stops the current expression (which should be a PARAM) and + # starts parsing a RHS expression which will be assigned to PARAM. + elsif ( $$sptr =~ s/^\s*=// ) + { + # Check that only preceding argument is variable + unless ( @list==1 ) + { return "Invalid assignment syntax (VAR = EXPRESSION) in $string_sav at $$sptr"; } + + my $param = $list[0]; + my $param_name = $param->Arglist->[0]; + + # Make sure parameter name not the same as built-in functions --Leonard + if ( exists $functions{ $param_name } ){ + return "Cannot use built-in function name '$param_name' as a parameter name."; + } + + unless ( $param->Type eq 'VAR' ) + { return "Attempted assignment to non-variable type in $string_sav at $$sptr."; } + + # save old variables + my $old_variables; + %{$old_variables} = %{$variables}; + %{$variables} = (); + # save old string_sav + my $old_string_sav = $string_sav; + + # Read remainder as expression + my $rhs = Expression->new(); + $err = $rhs->readString( $sptr, $plist, $end_chars, $level + 1 ); + if ($err) { return $err; } + + # check for recursive definitions + if ( exists $variables->{$param_name} ) + { return "Parameter $param_name is defined recursively."; } + + # fetch old variables and string_sav + %{$variables} = %{$old_variables}; + $string_sav = $old_string_sav; + + # assign the rhs expression to the parameter $vname + $plist->set( $param_name, $rhs ); + last; + } + + # Look for end characters + elsif ( $end_chars and ( $$sptr =~ /^\s*${end_chars}/ ) ) + { # end of expression + last; + } + else + { # nothing more to do + # TODO: add warning for trailing characters? + $$sptr =~ s/^\s*//; + last; + } + } + + # Chop leading whitespace + $$sptr =~ s/^\s*//; + + # look for a NUMBER + if ( my $num_expr = getNumber($sptr) ) + { + push @list, $num_expr; + $expect_op = 1; + next; + } + + # look for a function call + if ( $$sptr =~ s/^($ops_un)?\s*(\w+)\s*\(// ) + { + my $express_u; + if ( my $op = $1 ) + { # (optional) UNARY OP at start of expression, as in -a + b, or -a^2 + $express_u = Expression->new( Type=>$1 ); + } + + my $name = $2; + my @fargs = (); + my $type = ''; + my $nargs; + my ($param, $err); + if ($plist) + { + ($param, $err) = $plist->lookup($name); + } + if ( exists $functions{$name} ) + { + $type = "B"; + $nargs = $functions{$name}->{NARGS}; + } +# elsif ( $param and ($param->Type eq 'Observable') ) + elsif ( $param and defined $param->Type and ($param->Type eq 'Observable') ) + { + $type = "O"; + # number of args may be zero or one. + } +# elsif ( $param and ($param->Type eq 'Function') ) + elsif ( $param and defined $param->Type and ($param->Type eq 'Function') ) + { + $type = "F"; + $nargs = scalar( @{ $param->Ref->Args } ); + } + else + { + unless ( defined $param ) + { + if ($allowForward) + { $plist->set($name); } + else + { + return "Function $name is not a built-in function, Observable, or defined Function"; + } + } + } + + # Read arguments to function + while (1) + { + my $express = Expression->new(); + $err = $express->readString( $sptr, $plist, ',\)', $level + 1 ); + if ($err) { return $err; } + if ($express->Type) { push @fargs, $express; } + + if ( $$sptr =~ s/^\)// ) + { last; } + elsif ( $$sptr =~ s/^,// ) + { next; } + } + + # Check Argument list for consistency with function + if ( $type eq "O" ) + { + $nargs= scalar(@fargs); + if ($nargs>1){ + return ("Observables $name is called with too many arguments"); + } + elsif ($nargs==1) + { + # Argument must be VAR + if ($fargs[0]->Type ne "VAR"){ + return("Argument to observable must be a variable"); + } + # Argument to Observable must be Local type + (my $lv) = $plist->lookup($fargs[0]->Arglist->[0]); + if ($lv->Type ne "Local"){ + return( "Argument to observable must be a local variable" ); + } + } + } + else + { +# if ( $param and ($nargs != @fargs) ) + if ( $type ne '' and $param and ($nargs != @fargs) ) + { return "Incorrect number of arguments to function $name"; } + } + my $express = Expression->new( Type=>'FunctionCall', Arglist=>[$name, @fargs] ); + + if (defined $express_u) + { + push @{$express_u->Arglist}, $express; + push @list, $express_u; + } + else + { push @list, $express; } + + $expect_op = 1; + next; + } + + # VARIABLE + elsif ( $$sptr =~ s/^($ops_un)?\s*(\w+)// ) + { + my $express_u; + if ( my $op = $1 ) + { # (optional) UNARY OP at start of expression, as in -a + b, or -a^2 + $express_u = Expression->new( Type=>$1 ); + } + my $name = $2; + + # Validate against ParamList, if present + if ($plist) + { + # Create and set variable if next token is '=' + # otherwise create referenced variable but leave its Expr unset + unless ( $$sptr =~ /^\s*=/ ) + { + my ( $param, $err ) = $plist->lookup($name); + unless ( defined $param ) + { + if ($allowForward) + { $plist->set($name); } + else + { return "Can't reference undefined parameter $name"; } + } + } + } + else + { return "No parameter list provided"; } + + my $express = Expression->new( Type=>'VAR', Arglist=>[$name] ); + ++($variables->{$name}); + + if (defined $express_u) + { + push @{$express_u->Arglist}, $express; + push @list, $express_u; + } + else + { push @list, $express; } + + $expect_op = 1; + next; + } + + # Get expression enclosed in parentheses + elsif ( $$sptr =~ s/^($ops_un)?\s*\(// ) + { + my $express_u; + if ( my $op = $1 ) + { # (optional) UNARY OP at start of expression, as in -a + b, or -a^2 + $express_u = Expression->new( Type=>$1 ); + } + my $express = Expression->new(); + $err = $express->readString( $sptr, $plist, '\)', $level + 1 ); + if ($err) { return ($err); } + unless ( $$sptr =~ s/^\s*\)// ) + { return "Missing end parentheses in $string_sav at $$sptr"; } + + #printf "express=%s %s\n", $express->toString($plist), $$sptr; + if (defined $express_u) + { + push @{$express_u->Arglist}, $express; + push @list, $express_u; + } + else + { push @list, $express; } + + $expect_op = 1; + next; + } + elsif ( $end_chars and ($$sptr =~ /^\s*[${end_chars}]/) ) + { last; } + + # ERROR + else + { return "Expecting operator argument in $string_sav at $$sptr"; } + } + + # Transform list into expression preserving operator precedence + if (@list) { $expr->copy(arrayToExpression(@list)); } + + return $err; + } +} + + +### +### +### + + + + +# check if expression depends on parameter "varname" +sub depends +{ + my $expr = shift; + my $plist = shift; + my $varname = shift; + my $level = (@_) ? shift : 0; + my $dep = (@_) ? shift : {}; + + my $retval = ''; + my $err = ''; + + my $type = $expr->Type; + if ( $type eq 'NUM' ) + { + # this expression is a number: no dependency on varname + } + elsif ( $type eq 'VAR' ) + { + # this expression is a parameter name: check if parameter depends on varname + my $param_name = $expr->Arglist->[0]; + + if ( exists $dep->{$param_name} and $dep->{$param_name} ) + { + # cyclic dependency detected + $err = sprintf "Cycle in parameter $param_name looking for dep in %s", $varname; + print "$err\n"; + $retval = $param_name; + } + else + { + if ( $varname eq $param_name ) + { + # the parameter is varname: we found a dependency! + $retval = $param_name; + } + elsif ($plist) + { + # lookup parameter and see what it depends on.. + (my $param) = $plist->lookup($param_name); + if ( defined $param ) + { + # copy dependency hash and pass it down + my $new_dep = { %$dep }; + $new_dep->{$param_name} = 1; + (my $ret, $err) = $param->Expr->depends($plist, $varname, $level+1, $new_dep); + if ($ret) + { + $retval = $param_name . '->' . $ret; + } + } + } + } + } + else + { + # this expression is an operator, function or observable + # ..check if this depends on varname + my @arglist = @{ $expr->Arglist }; + # Skip function name if this is a function + if ( $type eq 'FunctionCall' ) { shift @arglist; } + foreach my $expr (@arglist) + { + ($retval, $err) = $expr->depends($plist, $varname, $level + 1, $dep); + last if $retval; + } + } + + return ($retval, $err); +} + + + +### +### +### + + + +# copy the contents of this expression into a second expression. +# NOTE: this is not recursive!! use the clone method to get a recursive copy +sub copy +{ + my $edest = shift; + my $esource = shift; + + $edest->Type( $esource->Type ); + $edest->Arglist( [ @{ $esource->Arglist } ] ); + return ($edest); +} + + + +### +### +### + + +# evaluate an expression and return a numerical value +sub evaluate +{ + my $expr = shift; + my $plist = (@_) ? shift : undef; + my $level = (@_) ? shift : 0; + + if ( $level > $MAX_LEVEL ) { die "Max recursion depth $MAX_LEVEL exceeded."; } + + my $val = undef; + if ( $expr->Type eq 'NUM' ) + { + $val = $expr->Arglist->[0]; + } + elsif ( $expr->Type eq 'VAR' ) + { + unless (defined $plist) + { die "Expression->evaluate: Error! Cannot evaluate VAR type without ParamList."; } + + my $name = $expr->Arglist->[0]; + $val = $plist->evaluate( $name, [], $level+1 ); + unless (defined $val) + { die "Expression->evaluate: Error! Parameter $name is not defined!\n"; } + } + elsif ( $expr->Type eq 'FunctionCall' ) + { + # first argument is function name + my $name = $expr->Arglist->[0]; + + if ( ref $name eq "Function" ) + { # anonymous function (TODO: double-check that its ok to be lazy about evaluating the args + $val = $name->evaluate( $expr->Arglist, $plist, $level+1); + } + elsif ( exists $functions{$name} ) + { # built-in function + my $f = $functions{$name}->{FPTR}; + # evaluate all the remaining arguments + my $eval_args = []; + my $ii=1; + while ( $ii < @{$expr->Arglist} ) + { + push @$eval_args, $expr->Arglist->[$ii]->evaluate($plist, $level+1); + ++$ii; + } + $val = $f->(@$eval_args); + } + + else + { # lookup user-defined function in paramlist + unless (defined $plist) + { die "Expression->evaluate: Error! Cannot evaluate user Function without ParamList."; } + + $val = $plist->evaluate( $name, $expr->Arglist, $level+1 ); + } + } + else + { + my $eval_string; + my $operator = $expr->Type; + + # replace non-perl operators with the perl equivalents + if ( $operator eq '~=' ) { $operator = '!='; } + elsif ( $operator eq '^' ) { $operator = '**'; } + elsif ( $operator eq '~' ) { $operator = '!'; } + + if ( @{$expr->Arglist} == 1 ) + { # handle unary operators + if ( $operator eq "/" ) + { + $eval_string = "1.0/(\$expr->Arglist->[0]->evaluate(\$plist,\$level+1))"; + } + else + { + $eval_string = "$operator(\$expr->Arglist->[0]->evaluate(\$plist,\$level+1))"; + } + + } + else + { + my $last = @{$expr->Arglist} - 1; + $eval_string = join "$operator", map {"(\$expr->Arglist->[$_]->evaluate(\$plist,\$level+1))"} (0..$last); + } + + # check if this is boolean type + if ( $operator =~ /[<>|&!=]/ ) + { + # evaluate the expression + local $SIG{__WARN__} = sub {}; + $val = eval "$eval_string" ? 1 : 0; + if ($@) { die $@; } + } + else + { + # evaluate the expression + local $SIG{__WARN__} = sub {}; + $val = eval "$eval_string"; + if ($@) { die $@; } + } + } + + return $val; +} + + + +### +### +### + + + +# Call this method to clone an expression and then descend into the expression +# and evaluate any local observables. The method returns the cloned variable +# with local observables evaluated as numbers. NOTE: this method will not +# work correctly if observables haven't been computed prior to the call. +sub evaluate_local +{ + my $expr = shift @_; + my $plist = @_ ? shift @_ : undef; + my $level = @_ ? shift @_ : 0; + + if ( $level > $MAX_LEVEL ) { return (undef, "Max recursion depth $MAX_LEVEL exceeded."); } + unless (defined $plist) { die "Expression->evaluate_local: Error! Function called without required ParamList."; } + + # local variables + my $local_expr = undef; + my $err = ''; + + # clone expression + ($local_expr, $err) = $expr->clone( $plist, $level+1 ); + + # evaluate local dependencies in arguments + foreach my $arg ( @{$local_expr->Arglist} ) + { + # only need to do this for expression arguments + if ( ref $arg eq 'Expression' ) + { $arg = $arg->evaluate_local($plist, $level+1); } + } + + # some additional handling for Function expressions! + if ( $expr->Type eq 'FunctionCall' ) + { + # if local arguments are passed to this function, then we + # must go into the function and evaluate the local bits. Then + # we need to create a clone of the function that has the local bits evaluated. + # Yuck! + + # First argument is the function name + my $name = $expr->Arglist->[0]; + + if ( ref $name eq "Function" ) + { # anonymous function.. + my $fcn = $name; + # get locally evaluated function + my ($local_fcn, $elim_args) = $fcn->evaluate_local( $local_expr->Arglist, $plist, $level+1 ); + + # if the local_fcn does not refer to observables of named functions, + # then we can convert it to a constant expression + my $dependencies = $local_fcn->Expr->getVariables($plist); + if ( @{$local_fcn->Args}==0 + and not exists $dependencies->{'Observable'} + and not exists $dependencies->{'Function'} ) + { # replace this fcn call with the localfcn expression + $local_expr = $local_fcn->Expr; + } + else + { # point this fcn call to the local expr + $local_expr->Arglist->[0] = $local_fcn; + # eliminate unused arguments + foreach my $iarg (@$elim_args) + { splice @{$local_expr->Arglist}, $iarg, 1; } + } + } + elsif ( exists $functions{$name} ) + { + # nothing to do + } + else + { # custom, named function + # lookup function parameter: + (my $fcn_param) = $plist->lookup( $name ); + + # Is this a true function or an observable?? + if ( $fcn_param->Type eq 'Function' ) + { + # get locally evaluated function + my ($local_fcn, $elim_args) = $fcn_param->Ref->evaluate_local( $local_expr->Arglist, $plist, $level+1 ); + + # if the local_fcn does not refer to observables of named functions, + # then we can convert it to a constant expression + my $dependencies = $local_fcn->Expr->getVariables($plist); + if ( @{$local_fcn->Args}==0 + and not exists $dependencies->{'Observable'} + and not exists $dependencies->{'Function'} ) + { # replace this fcn call with the localfcn expression + $local_expr = $local_fcn->Expr; + } + else + { # point this fcn call to the local expr + $local_expr->Arglist->[0] = $local_fcn; + # eliminate unused arguments + foreach my $iarg (@$elim_args) + { splice @{$local_expr->Arglist}, $iarg, 1; } + } + } + # This function is Really an Observable!! + elsif ( $fcn_param->Type eq 'Observable' ) + { + if ( @{$expr->Arglist} > 1 ) + { + # get locally evaluated function + my $val = $fcn_param->Ref->evaluate( $local_expr->Arglist, $plist, $level+1 ); + + # replace local expression with the evaluation + my $args = [ $val ]; + $local_expr->Type('NUM'); + $local_expr->Arglist($args); + $local_expr->Err(undef); + } + } + # The reference type is not known, abort with error! + else + { $err = "ERROR in Expression->evaluate_local(): expression is a function, but ref type is unknown!"; } + } + } + + return $local_expr; +} + + + +### +### +### + + +# check for local observable dependency, return true if found +sub checkLocalDependency +{ + my $expr = shift; + my $plist = shift; + my $level = (@_) ? shift : 0; + + unless ( defined $plist ) + { die "Expression->checkLocalDependency: Error! Missing argument ParamList!"; } + + + # check dependence of arguments + foreach my $arg ( @{$expr->Arglist} ) + { + if ( ref $arg eq 'Expression' ) + { + return 1 if ( $arg->checkLocalDependency( $plist, $level+1 ) ); + } + } + + if ( $expr->Type eq 'FunctionCall' ) + { + my $name = $expr->Arglist->[0]; + + if ( ref $name eq "Function" ) + { # anonymous function.. + my $fcn = $name; + return 1 if ( $fcn->checkLocalDependency( $plist, $level+1 ) ); + } + elsif ( exists $functions{$name} ) + { + # nothing to do + } + else + { # lookup custom function by name + my ($fcn_param) = $plist->lookup( $expr->Arglist->[0] ); + # is this a true function or an observable? + if ( $fcn_param->Type eq 'Function' ) + { + my $fcn = $fcn_param->Ref; + return 1 if ( $fcn->checkLocalDependency( $plist, $level+1 ) ); + } + elsif ( $fcn_param->Type eq 'Observable' ) + { + # function observables are locally dependent!! + return (@{$expr->Arglist} > 1 ? 1 : 0); + } + } + } + + return 0; +} + + +### +### +### + + +# check if two expressions are equivalent +sub equivalent +{ + my $expr1 = shift @_; + my $expr2 = shift @_; + my $plist = (@_) ? shift : undef; + my $level = (@_) ? shift : 0; + + # make sure we have defined expressions! + return 0 unless ( defined $expr1 and ref $expr1 eq 'Expression' ); + return 0 unless ( defined $expr2 and ref $expr2 eq 'Expression' ); + + # shortcut: first check if we're looking at the same object + return 1 if ( $expr1 == $expr2 ); + + # check type equivalence + return 0 unless ( $expr1->Type eq $expr2->Type ); + + # check for equal number of arguments + return 0 unless ( @{$expr1->Arglist} == @{$expr2->Arglist} ); + + # now we have to look deeper into the arguments + if ( $expr1->Type eq 'NUM' ) + { + # compare numbers + return ( $expr1->Arglist->[0] == $expr2->Arglist->[0] ); + } + elsif ( $expr2->Type eq 'VAR' ) + { + # compare var names + return ( $expr1->Arglist->[0] eq $expr2->Arglist->[0] ); + } + elsif ( $expr2->Type eq 'FunctionCall' ) + { + # compare function names (or refs) + return 0 unless ( ref $expr1->Arglist->[0] eq ref $expr2->Arglist->[0] ); + return 0 unless ( $expr1->Arglist->[0] eq $expr2->Arglist->[0] ); + + # check argument equivalence + for ( my $i = 1; $i < @{$expr1->Arglist}; ++$i ) + { + return 0 + unless ( Expression::equivalent($expr1->Arglist->[$i], $expr2->Arglist->[$i], $plist, $level+1) ); + } + } + else + { + # check argument equivalence + for ( my $i = 0; $i < @{$expr1->Arglist}; ++$i ) + { + return 0 + unless ( Expression::equivalent($expr1->Arglist->[$i], $expr2->Arglist->[$i], $plist, $level+1) ); + } + } + + # return true if no differences have been found + return 1; +} + + + + +# write this expression as a string. +# The expression is expanded up to the named Parameters and Functions. +sub toString +{ + my $expr = shift; + my $plist = (@_) ? shift : undef; + my $level = (@_) ? shift : 0; + my $expand = (@_) ? shift : 0; + + # simple error checking + if ( $level > $MAX_LEVEL ) { die "Max recursion depth $MAX_LEVEL exceeded."; } + if ( $expand and !$plist ) { die "Can't expand expression past parameters without a parameter list."; } + + # AS-2021 + if ( $expr->tfunFile ) { die "TFUN functions are not supported for non-NFsim simulators."; } + # AS-2021 + + # local variables + my $err; + my $string; + + # different handling depending on the type + my $type = $expr->Type; + if ( $type eq 'NUM' ) + { + # if number, print the numerical value! + $string = $expr->Arglist->[0]; + #print "NUM=$string\n"; + } + elsif ( $type eq 'VAR' ) + { + if ( $expand ) + { # descend recursively into parameter! + ( my $param, $err ) = $plist->lookup( $expr->Arglist->[0] ); + $string = $param->toString( $plist, $level+1, $expand ); + } + else + { # just write the parameter name + $string = $expr->Arglist->[0]; + } + #$string= $expr->evaluate($plist); + #print "VAR=$string\n"; + } + elsif ( $type eq 'FunctionCall' ) + { + my $name = $expr->Arglist->[0]; + if ( $expand or (ref $name eq "Function") ) + { # expand the function + my @sarr = ($expr->Arglist->[0]); + foreach my $i ( 1 .. $#{$expr->Arglist} ) + { push @sarr, $expr->Arglist->[$i]->toString($plist, $level+1, $expand); } + + if (ref $name eq "Function") + { # anonymous function + my $fcn = $name; + (my $local_fcn) = $fcn->evaluate_local( \@sarr, $plist, $level+1 ); + $string = $local_fcn->Expr->toString( $plist, $level+1, $expand ); + } + elsif ( exists $functions{$name} ) + { # built-in function + $string = $expr->Arglist->[0] . "(" . join(",", @sarr[1..$#sarr]) . ")"; + } + else + { # lookup custom function by name and expand + ( my $param, $err ) = $plist->lookup($name); + (my $local_fcn) = $param->Ref->evaluate_local( \@sarr, $plist, $level+1 ); + $string = $local_fcn->Expr->toString( $plist, $level+1, $expand ); + } + } + else + { # just write the function and its argument values + my @sarr = (); + foreach my $i ( 1 .. $#{$expr->Arglist} ) + { + push @sarr, $expr->Arglist->[$i]->toString( $plist, $level + 1 ); + } + $string = $name . '(' . join( ',', @sarr ) . ')'; + } + } + else + { + if ( $expand ) + { + my @sarr = (); + foreach my $e ( @{ $expr->Arglist } ) { + push @sarr, $e->toString( $plist, $level+1, $expand ); + } + if ( $#sarr > 0 ) + { $string = join( $type, @sarr ); } + else + { $string = $type . $sarr[0]; } + + # enclose in brackets if not at top level + # print "level=$level\n"; + if ($level) + { $string = '(' . $string . ')'; } + } + else + { + my @sarr = (); + foreach my $e ( @{ $expr->Arglist } ) { + push @sarr, $e->toString( $plist, $level + 1 ); + } + if ( $#sarr > 0 ) + { + $string = join( $type, @sarr ); + } + else { + $string = $type . $sarr[0]; + } + + # enclose in brackets if not at top level + # print "level=$level\n"; + if ($level) { + $string = '(' . $string . ')'; + } + #printf "%s=$string\n", $expr->Type; + } + } + + return $string; +} + + + +# write this expression as an XML string. +# Same as toString, except a few operators are replaced to avoid clashes with XML +sub toXML +{ + my $expr = shift; + my $plist = (@_) ? shift : undef; + my $level = (@_) ? shift : 0; + my $expand = (@_) ? shift : 0; + + # simple error checking + if ( $level > $MAX_LEVEL ) { die "Max recursion depth $MAX_LEVEL exceeded."; } + if ( $expand and !$plist ) { die "Can't expand expression past parameters without a parameter list."; } + + # local variables + my $err; + my $string; + + # different handling depending on the type + my $type = $expr->Type; + if ( $type eq 'NUM' ) + { + # if number, print the numerical value! + $string = $expr->Arglist->[0]; + } + elsif ( $type eq 'VAR' ) + { + if ( $expand ) + { + # descend recursively into parameter! + ( my $param, $err ) = $plist->lookup( $expr->Arglist->[0] ); + $string = $param->toXML( $plist, $level+1, $expand ); + } + else + { + # just write the parameter name + $string = $expr->Arglist->[0]; + } + } + elsif ( $type eq 'FunctionCall' ) + { + if ( $expand ) + { + # TODO + my @sarr = (); + foreach my $i ( 1 .. $#{$expr->Arglist} ) + { + push @sarr, $expr->Arglist->[$i]->toXML( $plist, $level + 1 ); + } + $string = $expr->Arglist->[0] . '(' . join( ',', @sarr ) . ')'; + } + else + { + my @sarr = (); + foreach my $i ( 1 .. $#{$expr->Arglist} ) + { + push @sarr, $expr->Arglist->[$i]->toXML( $plist, $level + 1 ); + } + $string = $expr->Arglist->[0] . '(' . join( ',', @sarr ) . ')'; + } + } + else + { + if ( $expand ) + { + my @sarr = (); + foreach my $e ( @{$expr->Arglist} ) + { + push @sarr, $e->toXML( $plist, $level+1, $expand ); + } + if ( $#sarr > 0 ) + { $string = join( $type, @sarr ); } + else + { $string = $type . $sarr[0]; } + + # enclose in brackets if not at top level + # print "level=$level\n"; + if ($level) + { $string = '(' . $string . ')'; } + } + else + { + my @sarr = (); + foreach my $e ( @{ $expr->Arglist } ) { + push @sarr, $e->toXML( $plist, $level + 1 ); + } + if ( $#sarr > 0 ) + { + $string = join( $type, @sarr ); + } + else { + $string = $type . $sarr[0]; + } + + # enclose in brackets if not at top level + # print "level=$level\n"; + if ($level) { + $string = '(' . $string . ')'; + } + #printf "%s=$string\n", $expr->Type; + } + } + + # TODO: special handling for XML output should be handled by a special option + # or a toXML sub. --Justin + + #BEGIN edit, msneddon + # for outputting to XML, we need to make sure we put in some special + # characters and operators to match the muParser library and to allow + # the XML parser to work.<" with "<", ">" with ">", and + #"&" with "& + #print "before XML replacement: $string\n"; + $string =~ s//>\;/; + $string =~ s/&&/and/; + $string =~ s/\|\|/or/; + #print "after XML replacement: $string\n"; + #END edit, msneddon + + # AS-2021 + if ($expr->tfunFile) { + # need to replace TFUN call from expr + my $cname = $expr->ctrName; + $string =~ s/TFUN\(\s*$cname\s*\)/__TFUN__VAL__/ + } + # AS-2021 + + return ($string); +} + + + + +# write expression as a string suitable for +# export to CVode. This is the same as toString, +# except variable names are replaced with pointers into +# arrays. +sub toCVodeString +{ + my $expr = shift; + my $plist = (@_) ? shift : ''; + my $level = (@_) ? shift : 0; + my $expand = (@_) ? shift : 0; + + if ( $level > $MAX_LEVEL ) { die "Max recursion depth $MAX_LEVEL exceeded."; } + + my $string; + my $err; + + my $type = $expr->Type; + + if ( $type eq 'NUM' ) + { + $string = $expr->Arglist->[0]; + # if this is a pure integer, + # add a decimal place to make sure C knows this has type double + $string =~ s/^(\d+)$/$1.0/; + } + elsif ( $type eq 'VAR' ) + { + # lookup corresponding parameter ... + (my $param, $err) = $plist->lookup( $expr->Arglist->[0] ); + if ($param) + { # return cvode ref + $string = $param->getCVodeName(); + } + else + { # parameter not defined, assume it's a local argument and write its name + $string = $expr->Arglist->[0]; + } + } + elsif ( $type eq 'FunctionCall' ) + { + # the first argument is the function name + my $fcn_name = $expr->Arglist->[0]; + + if ( ref $fcn_name eq "Function" ) + { # anonymous function + my $fcn = $fcn_name; + # we can't call function by name, so we have to expand the function expression with args in place + (my $local_fcn) = $fcn->evaluate_local( [@{$expr->Arglist}], $plist, $level+1 ); + unless (defined $local_fcn) { die "Error in Expression->toMatlabString(): some problem evaluating anonymous function"; } + $string = $local_fcn->Expr->toCVodeString($plist, $level+1, $expand); + } + elsif ( isBuiltIn($fcn_name) ) + { + # convert '_pi()' to 'pi' + if ($fcn_name eq '_pi'){ $string = 'M_PI'; } + + # convert '_e()' to 'exp(1)' + elsif ( $fcn_name eq '_e' ){ $string = "M_E"; } + + # handle the 'if' built-in with 3 arguments + elsif ( $fcn_name eq 'if' ) + { + # substitute the "?" operator for the if function + my @sarr = ( map {$_->toCVodeString($plist, $level+1)} @{$expr->Arglist}[1..$#{$expr->Arglist}] ); + + if ( @sarr == 3 ) + { $string = '('. $sarr[0] .' ? '. $sarr[1] .' : '. $sarr[2] .')'; } + else + { die "Error in Expression->toCVodeString(): built-in function 'if' must have three arguments!"; } + } + + # handle the 'sum' and 'avg' built-ins with >=1 argument + elsif( $fcn_name eq 'sum' or $fcn_name eq 'avg') + { + my @sarr = ( map {$_->toCVodeString($plist, $level+1)} @{$expr->Arglist}[1..$#{$expr->Arglist}] ); + if ( @sarr ge 1 ) + { + $string = '('. $sarr[0]; + for(my $i=1; $i < scalar(@sarr); $i++){ + $string .= '+'. $sarr[$i]; + } + $string .= ')'; + # if 'avg', divide sum by number of elements + if ( $fcn_name eq 'avg' ) + { $string = '(' . $string . '/' . scalar(@sarr) . ')'; } + } + else + { die "Error in Expression->toCVodeString(): built-in function $fcn_name must have at least 1 argument!"; } + } + + # all other built-ins + else + { + if ($fcn_name eq 'ln'){ $fcn_name = 'log'; } # change 'ln' to 'log' + if ($fcn_name eq 'min'){ $fcn_name = 'fmin'; } # change 'min' to 'fmin' + if ($fcn_name eq 'max'){ $fcn_name = 'fmax'; } # change 'max' to 'fmax' + my @sarr = ( map {$_->toCVodeString($plist, $level+1, $expand)} @{$expr->Arglist}[1..$#{$expr->Arglist}] ); + $string = $fcn_name .'('. join( ',', @sarr ) .')'; + } + } + else + { # user-defined function or observable + # lookup function parameter: + (my $fcn_param) = $plist->lookup( $fcn_name ); + unless ($fcn_param) + { die "Error in Expression->toCVodeString: could not find function parameter!"; } + + # Is this a true function or an observable?? + if ( $fcn_param->Type eq 'Function' ) + { # Handling a true Function! + # expand argument expressions up until named entities + my @sarr = ( map {$_->toCVodeString($plist, $level+1, $expand)} @{$expr->Arglist}[1..$#{$expr->Arglist}] ); + # pass arguments pointing to the expressions array and observables array + push @sarr, 'expressions', 'observables'; + $string = $fcn_name . '(' . join( ',', @sarr ) . ')'; + } + elsif ( $fcn_param->Type eq 'Observable' ) + { + # TODO: if there are arguments, then we should warn the user that we can't evaluate a local + # observables in a CVode function!! + $string = $fcn_param->getCVodeName(); + } + else + { die "Error in Expression->toCVodeString(): don't know how to process function expression of non-function type!"; } + + } + + } + elsif ( ($type eq '**') or ($type eq '^') ) + { + # substitute the "pow" function for the exponentiation operator + my @sarr = ( map {$_->toCVodeString($plist, $level+1)} @{$expr->Arglist} ); + + if ( @sarr == 2 ) + { $string = 'pow(' . $sarr[0] . ',' . $sarr[1] . ')'; } + else + { die "Error in Expression->toCVodeString(): Exponentiation must have exactly two arguments!"; } + } + else + { + # handling some other operator (+,-,*,/) + # enclose in brackets (always. just to be safe) + my @sarr = ( map {$_->toCVodeString($plist, $level+1, $expand)} @{$expr->Arglist} ); + if ( @sarr > 1 ) + { # binary or higher order + $string = '(' . join( $type, @sarr ) . ')'; + } + else + { # unary operator + $string = '(' . $type . $sarr[0] . ')'; + } + } + + return ($string); +} + + + + +# write expression as a string suitable for +# export to a Matlab M-file. +sub toMatlabString +{ + my $expr = shift @_; + my $plist = @_ ? shift @_ : undef; + my $level = @_ ? shift @_ : 0; + my $expand = @_ ? shift @_ : 0; + + if ( $level > $MAX_LEVEL ) { die "Max recursion depth $MAX_LEVEL exceeded."; } + + my $string; + my $err; + + my $type = $expr->Type; + + if ( $type eq 'NUM' ) + { + $string = $expr->Arglist->[0]; + } + elsif ( $type eq 'VAR' ) + { + # lookup corresponding parameter ... + (my $param, $err) = $plist->lookup( $expr->Arglist->[0] ); + if ($param) + { # return matlab ref + $string = $param->getMatlabName(); + } + else + { # parameter not defined, assume it's a local argument and write its name + $string = $expr->Arglist->[0]; + } + } + elsif ( $type eq 'FunctionCall' ) + { + # the first argument is the function name + my $fcn_name = $expr->Arglist->[0]; + + if ( ref $fcn_name eq "Function" ) + { # anonymous function! + my $fcn = $fcn_name; + # we can't call function by name, so we have to expand the function expression with args in place + (my $local_fcn) = $fcn->evaluate_local( [@{$expr->Arglist}], $plist, $level+1 ); + unless (defined $local_fcn) { die "Error in Expression->toMatlabString(): some problem evaluating anonymous function"; } + $string = $local_fcn->Expr->toMatlabString($plist, $level+1, $expand); + } + elsif ( isBuiltIn($fcn_name) ) + { + # convert '_pi()' to 'pi' + if ($fcn_name eq '_pi'){ $string = 'pi'; } + + # convert '_e()' to 'exp(1)' + elsif ( $fcn_name eq '_e' ){ $string = "exp(1)"; } + + # handle the 'rint' built-in with 1 argument + elsif ( $fcn_name eq 'rint' ) + { + my @sarr = ( map {$_->toMatlabString($plist, $level+1)} @{$expr->Arglist}[1..$#{$expr->Arglist}] ); + if ( @sarr == 1) + { + $string = sprintf( "floor(%s+0.5)", $sarr[0] ); + } + else + { die "Error in Expression->toMatlabString(): built-in function 'rint' must have one argument!"; } + } + + # handle the 'if' built-in with 3 arguments + elsif ( $fcn_name eq 'if' ) + { + # substitute the "?" operator for the if function + my @sarr = ( map {$_->toMatlabString($plist, $level+1)} @{$expr->Arglist}[1..$#{$expr->Arglist}] ); + + if ( @sarr == 3) + { # TODO: find better solution here. this version will return NaN if either return value is Inf. + #$string = sprintf( "((%s~=0)*%s + (%s==0)*%s)", $sarr[0], $sarr[1], $sarr[0], $sarr[2]); + $string = sprintf( "if__fun( %s, %s, %s)", $sarr[0], $sarr[1], $sarr[2]); + } + else + { die "Error in Expression->toMatlabString(): built-in function 'if' must have three arguments!"; } + } + + # all other built-ins + else + { + if ($fcn_name eq 'ln'){ $fcn_name = 'log'; } # change 'ln' to 'log' + if ($fcn_name eq 'avg'){ $fcn_name = 'mean'; } # change 'avg' to 'mean' + my @sarr = ( map {$_->toMatlabString($plist, $level+1, $expand)} @{$expr->Arglist}[1..$#{$expr->Arglist}] ); + $string = $fcn_name .'('. join( ',', @sarr ) .')'; + } + } + else + { # this is a user-defined function or observable + # lookup function parameter: + (my $fcn_param) = $plist->lookup( $fcn_name ); + unless ($fcn_param) + { die "Error in Expression->toMatlabString: could not find function parameter!"; } + + # Is this a true function or an observable?? + if ( $fcn_param->Type eq 'Function' ) + { # Handling a true Function! + # expand argument expressions up until named entities + my @sarr = ( map {$_->toMatlabString($plist, $level+1, $expand)} @{$expr->Arglist}[1..$#{$expr->Arglist}] ); + # pass arguments pointing to the expressions array and observables array + push @sarr, 'expressions', 'observables'; + $string = $fcn_name . '(' . join( ',', @sarr ) . ')'; + } + elsif ( $fcn_param->Type eq 'Observable' ) + { + # TODO: if there are arguments, then we should warn the user that we can't evaluate a local + # observables in a CVode function!! + $string = $fcn_param->getMatlabName(); + } + else + { die "Error in Expression->toMatlabString(): don't know how to process function expression of non-function type!"; } + } + + } + else + { + # handling some other operator (+,-,*,/) + # enclose in brackets (always. just to be safe) + my @sarr = ( map {$_->toMatlabString($plist, $level+1, $expand)} @{$expr->Arglist} ); + if ( @sarr > 1 ) + { # binary or higher order + $string = '(' . join( $type, @sarr ) . ')'; + } + else + { # unary operator + $string = '(' . $type . $sarr[0] . ')'; + } + } + + return $string; +} + + +### +### +### + + +{ + my %ophash = + ( + '+' => 'plus', + '-' => 'minus', + '*' => 'times', + '/' => 'divide', + '**' => 'power', + '^' => 'power', + '&&' => 'and', + '||' => 'or', + '<' => 'lt', + '>' => 'gt', + '<=' => 'leq', + '>=' => 'geq', + '!=' => 'neq', + '==' => 'equivalent' + ); + + my %fnhash = + ( + '_pi' => 'pi', + '_e' => 'exponentiale', + 'exp' => 'exp', + 'ln' => 'ln', + 'log10' => 'log', +# 'log2' => Requires special handling (see below) + 'abs' => 'abs', +# 'rint' => Requires special handling (see below) + 'sqrt' => 'root', + 'cos' => 'cos', + 'sin' => 'sin', + 'tan' => 'tan', + 'asin' => 'arcsin', + 'acos' => 'arccos', + 'atan' => 'arctan', + 'sinh' => 'sinh', + 'cosh' => 'cosh', + 'tanh' => 'tanh', + 'asinh' => 'arcsinh', + 'acosh' => 'arccosh', + 'atanh' => 'arctanh', +# 'if' => Requires special handling (see below) + 'min' => 'min', + 'max' => 'max', + 'sum' => 'sum', + 'avg' => 'mean' + ); + + sub toMathMLString + { + my $expr = shift; + my $plist = (@_) ? shift : ''; + my $indent = (@_) ? shift : ''; + my $level = (@_) ? shift : 0; + + if ( $level > $MAX_LEVEL ) { die "Max recursion depth $MAX_LEVEL exceeded."; } + + my $string = ""; + my $indentp = $indent; + if ( $level == 0 ) + { + $string .= + $indent . "\n"; + $indentp .= " "; + } + + my $type = $expr->Type; + if ( $type eq 'NUM' ) + { + $string .= sprintf "%s %s \n", $indentp, $expr->Arglist->[0]; + } + elsif ( $type eq 'VAR' ) + { + $string .= sprintf "%s %s \n", $indentp, $expr->Arglist->[0]; + } + elsif ( $type eq 'FunctionCall' ) { + my @arglist = @{ $expr->Arglist }; + my $func_name = shift(@arglist); # Get function name + + # Built-in functions + if (isBuiltIn($func_name)){ + + # Special handling for log2(x) + if ($func_name eq 'log2'){ + $string .= $indentp . "\n"; + $string .= $indentp . " 2\n"; + $string .= $arglist[0]->toMathMLString( $plist, $indentp . " ", $level + 1 ); + $string .= $indentp . "\n"; + } + # Special handling for rint(x) + elsif ($func_name eq 'rint'){ + $string .= $indentp . "\n"; + $string .= $indentp . " \n"; + $string .= $indentp . " \n"; + $string .= $indentp . " \n"; + $string .= $indentp . " 0.5 \n"; + $string .= $arglist[0]->toMathMLString( $plist, $indentp . " ", $level + 1 ); + $string .= $indentp . " \n"; + $string .= $indentp . "\n"; + } + # Special handling for if(x,y,z) + elsif ($func_name eq 'if'){ + $string .= $indentp . "\n"; + $string .= $indentp . " \n"; + $string .= $arglist[1]->toMathMLString( $plist, $indentp . " ", $level + 1 ); + $string .= $arglist[0]->toMathMLString( $plist, $indentp . " ", $level + 1 ); + $string .= $indentp . " \n"; + $string .= $indentp . " \n"; + $string .= $arglist[2]->toMathMLString( $plist, $indentp . " ", $level + 1 ); + $string .= $indentp . " \n"; + $string .= $indentp . "\n"; + } + # All other built-ins + else{ + $string .= $indentp . "\n"; + my $indentpp = $indentp . " "; + $string .= sprintf "%s<%s/>\n", $indentpp, $fnhash{ $func_name }; #shift(@arglist); + foreach my $e (@arglist) + { + $string .= $e->toMathMLString( $plist, $indentpp, $level + 1 ); + } + $string .= $indentp . "\n"; + } + } + # User-defined functions + else{ + if (@arglist){ # There better not be any arguments + die "Expression::toMathMLString: User-defined functions should not have arguments."; + } + $string .= sprintf "%s %s \n", $indentp, $func_name; + } + } + else + { + $string .= $indentp . "\n"; + my $indentpp = $indentp . " "; + $string .= sprintf "%s<%s/>\n", $indentpp, $ophash{ $expr->Type }; + foreach my $e ( @{ $expr->Arglist } ) + { + $string .= $e->toMathMLString( $plist, $indentpp, $level + 1 ); + } + $string .= $indentp . "\n"; + } + + if ( $level == 0 ) + { + $string .= $indent . "\n"; + } + return $string; + } +} + +# Convert an array of type EXPR OP EXPR OP ... to a single Expression. +sub arrayToExpression +{ + my @earr = @_; + + # list of optypes in order of precedence + my @operators = ('\*\*|\^', '[*/]', '[+-]', '[<>]|==|!=|~=|>=|<=', '&&|\|\|'); + my $optype = shift @operators; + while ($optype) + { + my $i = 0; + # Consolidate EXPR OP EXPR into EXPR + while ($i < $#earr) + { + my $expr = $earr[$i]; + if ( $expr->Type =~ /$optype/ and !@{$expr->Arglist} ) + { + if ( $i > 0 ) + { + $expr->Arglist->[0] = $earr[ $i - 1 ]; + $expr->Arglist->[1] = $earr[ $i + 1 ]; + splice @earr, $i - 1, 3, $expr; + next; + } + else + { + # Handle leading unary op, as in -a + b + $expr->Arglist->[0] = $earr[ $i + 1 ]; + splice @earr, $i, 2, $expr; + ++$i; + next; + } + } + ++$i; + } + # Finished with current optype + $optype = shift @operators; + } + + return $earr[0]; +} + + + +# extract a number expression from a BNG string. +# NOTE: the method newNumOrVar is appropriate when +# the string ONLY contains a number or param name. This +# method, however, is suitable for cases where the string +# contains additional content. +sub getNumber +{ + my $string = shift; + + my $number = ''; + # Decimal part + if ( $$string =~ s/^([+-]?\d+)([.]?\d*)// ) + { + $number = $1; + if ($2 eq '.') + { # pad number ending in decimal point + $number .= ".0"; + } + else + { + $number .= $2; + } + } + elsif ( $$string =~ s/^([+-]?[.]\d+)// ) + { + $number = $1; + } + else + { + return ''; + } + + # Exponent part + if ( $$string =~ s/^([DEFGdefg][+-]?\d+)// ) + { + $number .= $1; + } + elsif ( $$string =~ /^[A-Za-z_]/ ) + { + # String is non a number; restore value of string + $$string = $number . $$string; + return ''; + } + + # create number expression and return + my $express = Expression->new(); + $express->Type('NUM'); + $express->Arglist( [$number] ); + return $express; +} + + + +# Returns name of VAR if expression is an existing VAR or +# creates a new VAR with name derived from $basename and +# returns name of new VAR containing expression. +sub getName +{ + my $expr = shift @_; + my $plist = shift @_; + my $basename = @_ ? shift @_ : "k"; + my $force_fcn = @_ ? shift @_ : 0; + + my $name; + if ( $expr->Type eq 'VAR' and !$force_fcn ) + { + $name = $expr->Arglist->[0]; + } + elsif ( $expr->Type eq "FunctionCall" + and @{$expr->Arglist}==1 + and ref $expr->Arglist->[0] ne "Function" ) + { # function call without arguments, no need to create a new parameter + $name = $expr->Arglist->[0]; + } + elsif ( $expr->Type eq "FunctionCall" + and $expr->Arglist->[0] =~ /^$basename/ ) + { # already a derived function, no need to create a new parameter + $name = $expr->Arglist->[0]; + } + else + { + # Find unused name + my $index = 1; + while (1) + { + my ($param, $err) = $plist->lookup($basename . $index); + last unless $param; + ++$index; + } + $name = $basename . $index; + # set parameter in list (with type Function, if force) + $plist->set( $name, $expr, 0, ($force_fcn ? 'Function' : '') ); + } + + return $name; +} + + + +# Return a hash of all the variable names referenced in the current expression. +sub getVariables +{ + my $expr = shift @_; + my $plist = shift @_; + my $level = @_ ? shift @_ : 0; + my $rethash = @_ ? shift @_ : {}; + + if ($level > $MAX_LEVEL) { die "Max recursion depth $MAX_LEVEL exceeded."; } + + my $type = $expr->Type; + if ( $type eq 'NUM' ) + { + # nothing to do + } + elsif ( $type eq 'VAR' ) + { + my ($param, $err) = $plist->lookup( $expr->Arglist->[0] ); + if ($err) { die $err }; # Shouldn't be an undefined variable name here + if ( defined $param->Type ) + { # add parameter name to type hash + $rethash->{$param->Type}->{$param->Name} = $param; + } + else + { # this parameter has undefined type! + $rethash->{'UNDEF'}->{$param->Name} = $param; + } + } + elsif ( $type eq 'FunctionCall' ) + { + if ( ref $expr->Arglist->[0] eq "Function" ) + { # anonymous function + # we have to descend into the function expression to see what it may reference + $expr->Arglist->[0]->Expr->getVariables($plist, $level+1, $rethash); + } + elsif ( exists $functions{$expr->Arglist->[0]} ) + { # built-in function.. + # nothing to do + } + else + { # named function + my ($param, $err) = $plist->lookup( $expr->Arglist->[0] ); +# if (defined $param) + if (defined $param && defined $param->Type) + { # add named function to rethash + $rethash->{$param->Type}->{$param->Name} = $param; + } + } + + # handle the function arguments + foreach my $i ( 1 .. $#{$expr->Arglist} ) + { + $expr->Arglist->[$i]->getVariables($plist, $level+1, $rethash); + } + } + else + { + foreach my $e ( @{$expr->Arglist} ) + { + $e->getVariables($plist, $level + 1, $rethash); + } + } + + return $rethash; +} + +1; diff --git a/libvcell/vcell_install/bionetgen/Perl2/Function.pm b/libvcell/vcell_install/bionetgen/Perl2/Function.pm new file mode 100644 index 0000000..a66a6ee --- /dev/null +++ b/libvcell/vcell_install/bionetgen/Perl2/Function.pm @@ -0,0 +1,566 @@ +package Function; + +# pragmas +use strict; +use warnings; + +# Perl Modules +use Class::Struct; +use FindBin; +use lib $FindBin::Bin; + +# BNG Modules +use ParamList; +use Expression; + + + +struct Function => +{ + Name => '$', + Args => '@', + Expr => 'Expression', + LocalHash => '%', +}; + + +### +### +### + + +# create a copy of this function. +# +sub clone +{ + my $fcn = shift @_; + my $plist = @_ ? shift @_ : undef; + my $level = @_ ? shift @_ : 0; + my $named = @_ ? shift @_ : 0; + + # if the clone doesn't have a name, it will be anonymous + my $clone_name = $named ? $fcn->Name : undef; + + my $err = ''; + (my $clone_expr, $err) = $fcn->Expr->clone( $plist, $level+1 ); + + my $clone = Function->new( Name=>$clone_name, Expr=>$clone_expr, Args=>[@{$fcn->Args}] ); + return $clone, $err; +} + + +### +### +### + +sub evaluate +{ + my $fcn = shift @_; + my $args = @_ ? shift @_ : []; + my $plist = @_ ? shift @_ : undef; + my $level = @_ ? shift @_ : 0; + + # create local parameterList + my $local_plist = $plist->getChildList(); + + # set local variables equal to the arguments + my $ii=1; # first arg is function name + while ( $ii < @$args ) + { + $local_plist->set( $fcn->Args->[$ii-1], $args->[$ii], 1, $args->[$ii]->Type ); + ++$ii; + } + + # evaluate function expression + return $fcn->Expr->evaluate($local_plist, $level+1); +} + + +### +### +### + + + +# return a cloned function with local elements evaluated +sub evaluate_local +{ + my $fcn = shift; + my $args = (@_) ? shift : []; + my $plist = (@_) ? shift : undef; + my $level = (@_) ? shift : 0; + + my ($local_fcn, $err) = $fcn->clone( $plist, $level+1 ); + + # create local parameterList + my $local_plist = $plist->getChildList(); + # set local variables equal to the arguments + my $ii=1; # first arg is function name + while ( $ii < @$args ) + { + $local_plist->set( $fcn->Args->[$ii-1], $args->[$ii], 1 ); + ++$ii; + } + + # locally evaluate function expression + my $expr = $local_fcn->Expr->evaluate_local($local_plist, $level+1); + $local_fcn->Expr($expr); + + # check if local variables are unused + my $bad_args = []; + $ii=0; + while ( $ii < @{$local_fcn->Args} ) + { + my ($dep, $err) = $expr->depends( $plist, $fcn->Args->[$ii] ); + if ($dep) + { + # do nothing + ++$ii; + } + else + { + # remove argument + splice @{$local_fcn->Args}, $ii, 1; + push @$bad_args, $ii+1; + } + } + + return $local_fcn, $bad_args; +} + + +### +### +### + + +# check for local observable dependency, return true if found +sub checkLocalDependency +{ + my $fcn = shift; + my $plist = (@_) ? shift : undef; + my $level = (@_) ? shift : 0; + + return $fcn->Expr->checkLocalDependency( $plist, $level+1 ); +} + + +### +### +### + + +# check function equivalence +sub equivalent +{ + my $fcn1 = shift; + my $fcn2 = shift; + my $plist = (@_) ? shift : undef; + + # make sure we have defined expressions! + return 0 unless ( defined $fcn1 and ref $fcn1 eq 'Function' ); + return 0 unless ( defined $fcn2 and ref $fcn2 eq 'Function' ); + + # check if this is the same function object! + return 0 if ( $fcn1 == $fcn2 ); + + # don't compare names!!! + + # check for same number of arguments + return 0 unless ( @{$fcn1->Args} == @{$fcn2->Args} ); + + # compare arguments + for ( my $i = 0; $i < @{$fcn1->Args}; ++$i ) + { + return 0 unless ( $fcn1->Args->[$i] eq $fcn2->Args->[$i] ); + } + + # check Expr equivalence + return 0 unless ( Expression::equivalent($fcn1->Expr, $fcn2->Expr, $plist) ); + + # no differences found, return true! + return 1; +} + + +### +### +### + + +sub readString +{ + my $fun = shift; + my $string = shift; + my $model = shift; + my $err = ''; + + my $plist = $model->ParamList; + + # Remove leading whitespace + $string =~ s/^\s*//; + + # Check if first token is an index + $string =~ s/^\s*\d+\s+//; # Can't deprecate this because indices used in NET files + + # Remove leading label, if exists + if ( $string =~ s/^\s*(\w+)\s*:\s+// ) + { + # Check label for leading number + my $label = $1; + if ($label =~ /^\d/) { return "Syntax error (label begins with a number) at '$label'"; } + } + + # Check name for leading number + my $string_left = $string; + unless ( $string_left =~ s/^([A-Za-z_]\w*)// ) + { + return "Syntax error (function name begins with a number) at '$string'"; + } + + # Next token is function Name + if ( $string =~ s/^\s*([A-Za-z0-9_]+)\s*// ) + { + my $name = $1; + $fun->Name($name); + + # Make sure function name not the same as built-in functions --Leonard + if ( Expression::isBuiltIn($name) ){ + return "Cannot use built-in function name '$name' as a user-defined function name."; + } + } + else + { + my ($name) = split( ' ', $string ); + return ("Invalid function name '$name': may contain only alphanumeric characters and underscore"); + } + + # Process arguments to function (if any) + my @Args = (); + if ( $string =~ s/^[(]\s*// ) + { + while (1) + { + if ( $string =~ s/^\s*([A-Za-z0-9_]+)\s*// ) + { + my $arg = $1; + # Define argument as an allowed local variable in $plist + if ( $plist->set( $arg, '0', 1, 'Local' ) ) + { + my $name = $fun->Name; + return ("Local argument $arg to Function $name matches previously defined variable"); + } + #printf "Added argument %s to function %s\n", $arg, $fun->Name; + push @Args, $arg; + } + elsif ( $string =~ s/^[,]\s*// ) + { + next; + } + elsif ( $string =~ s/^[)]\s*// ) + { + last; + } + else + { + my $name= $fun->Name; + return ("Unrecognized argument at $string in declaration of function $name."); + } + } + $fun->Args( [@Args] ); + } + + # Remove '=' if present (but NOT '==') + $string=~ s/(?new(); + $expr->setAllowForward(1); # don't complain if expression refers to undefined parameters + if ( my $err = $expr->readString( \$string, $plist ) ) { return ($err); } + if ($string) { return ("Syntax error at $string"); } + $expr->setAllowForward(0); + + $fun->Expr($expr); + + # Define parameter with name of the Function + if ( $plist->set( $fun->Name, $expr, 1, "Function", $fun ) ) + { + my $name = $fun->Name; + return ("Function name $name matches previously defined variable"); + } + + $fun->unsetArgs($plist); + + return ''; +} + + +### +### +### + + +sub toString +{ + my $fun = shift @_; + my $plist = @_ ? shift @_ : undef; + my $include_equal = (@_) ? shift : 0; + # used for aligning columns nicely + my $max_length = (@_) ? shift : 0; + + my $name = defined $fun->Name ? $fun->Name : "anon"; + my $string = $name . '(' . join(',', @{$fun->Args}) . ')'; + if ( $fun->Expr ) + { + $string .= ($include_equal) ? ' = ' : ' '; + $string .= $fun->Expr->toString($plist); + } + + if ($include_equal and $max_length) + { # align equal signs + $string =~ /=/g; + my $n_spaces = $max_length - pos $string; + if ($n_spaces > 0) + { + my $spaces = ' ' x $n_spaces; + $string =~ s/=/$spaces=/; + } + } + + return $string; +} + + +### +### +### + + +sub toCVodeString +# construct a call, declaration or definition for this function in CVode. +{ + my $fcn = shift; # this function + my $plist = (@_) ? shift : undef; # reference to ParamList + my $arghash = (@_) ? shift : {}; # reference to argument hash + + # set default mode + unless ( exists $arghash->{fcn_mode} ) + { $arghash->{fcn_mode} = 'call'; } + + # set default indent + unless ( exists $arghash->{indent} ) + { $arghash->{indent} = ''; } + + my $string = ''; + if ( $arghash->{fcn_mode} eq 'call' ) + { + # generate the function call + my @args = ( @{$fcn->Args}, 'expressions', 'observables' ); + $string = $arghash->{indent} . $fcn->Name . '(' . join(',', @args) . ')'; + } + elsif ( $arghash->{fcn_mode} eq 'declare' ) + { + # generate a declaration string + my @args = ( (map { "double $_" } @{$fcn->Args}), 'N_Vector expressions', 'N_Vector observables' ); + $string = $arghash->{indent} . "double " . $fcn->Name . " ( " . join(', ', @args) . " );\n"; + } + elsif ( $arghash->{fcn_mode} eq 'define' ) + { + # generate a definition string + my @args = ( (map { "double $_" } @{$fcn->Args}), 'N_Vector expressions', 'N_Vector observables' ); + + $string .= $arghash->{indent} . "/* user-defined function " . $fcn->Name . " */\n"; + $string .= $arghash->{indent} . "double " . $fcn->Name . " ( " . join(', ', @args) . " )\n"; + $string .= $arghash->{indent} . "{\n"; + $string .= $arghash->{indent} . " return " . $fcn->Expr->toCVodeString($plist) . ";\n"; + $string .= $arghash->{indent} . "}\n"; + } + else + { die "Error in Function->toCVodeString(): did not recognize fcn_mode argument!"; } + + return $string; +} + + + +### +### +### + + + +sub toMatlabString +# construct a call, declaration or definition for this function in CVode. +{ + my $fcn = shift @_; # this function + my $plist = @_ ? shift @_ : undef; # reference to ParamList + my $arghash = @_ ? shift @_ : {}; # reference to argument hash + + # set default mode + unless ( exists $arghash->{fcn_mode} ) + { $arghash->{fcn_mode} = 'call'; } + + # set default indent + unless ( exists $arghash->{indent} ) + { $arghash->{indent} = ''; } + + my $string = ''; + if ( $arghash->{fcn_mode} eq 'call' ) + { + # generate the function call + my @args = ( @{$fcn->Args}, 'expressions', 'observables' ); + $string = $arghash->{indent} . $fcn->Name . '(' . join(',', @args) . ')'; + } + elsif ( $arghash->{fcn_mode} eq 'declare' ) + { + # generate a declaration string + # NOTHING TO DO: Matlab does not require function declarations + $string = ''; + } + elsif ( $arghash->{fcn_mode} eq 'define' ) + { + # generate a definition string + my @args = ( @{$fcn->Args}, 'expressions', 'observables' ); + $string .= $arghash->{indent} . '% function ' . $fcn->Name . "\n"; + $string .= $arghash->{indent} . 'function [val] = ' . $fcn->Name . '(' . join(', ', @args) . ")\n" + . ' val = ' . $fcn->Expr->toMatlabString($plist) . ";\n" + . "end\n"; + } + else + { die "Error in Function->toMatlabString(): did not recognize fcn_mode argument!"; } + + return $string; +} + + + +### +### +### + + + +sub setArgs +{ + my $fun= shift; + my $plist= shift; + + foreach my $arg ( @{$fun->Args} ) + { + $plist->set( $arg, '0', 1, 'Local' ); + } + return ''; +} + + + +### +### +### + + + +sub unsetArgs +{ + my $fun = shift; + my $plist = shift; + + # Delete ParamList entries for Local arguments + foreach my $arg ( @{$fun->Args} ) + { + $plist->deleteLocal($arg); + } + return ''; +} + + + +### +### +### + + + +sub toXML +{ + my $fun = shift; + my $plist = (@_) ? shift : ''; + my $indent = (@_) ? shift : ''; + + $fun->setArgs($plist); + + my $indent2 = ' ' . $indent; + my $indent3 = ' ' . $indent2; + my $string = $indent . "Name."\""; + + # AS-2021 + # if we have a TFUN type function, we need to add + # some attributes to the function XML + if($fun->Expr->tfunFile) + { + # we need type and file attributes + $string .= " type=\"TFUN\""; + $string .= " file=\"".$fun->Expr->tfunFile."\""; + $string .= " ctrName=\"".$fun->Expr->ctrName."\""; + } + # AS-2021 + + # close up this level + $string .= ">\n"; + + # Arguments + if ( @{$fun->Args} ) + { + $string.= $indent2 . "\n"; + foreach my $arg (@{$fun->Args}) + { + $string .= $indent3 . "\n"; + } + + # References + $string.= $indent2."\n"; + # AS-2021 + # if we have a TFUN type function, we need to add + # a default reference + if($fun->Expr->tfunFile) + { + # we need type and file attributes + $string .= $indent3 . "\n" + } + # AS-2021 + my $vhash= $fun->Expr->getVariables($plist); + + foreach my $type (sort keys %{$vhash}) + { + foreach my $var (sort keys %{$vhash->{$type}}) + { + #print "$type $var\n"; + $string .= $indent3 . ($vhash->{$type}->{$var})->toXMLReference('Reference', '', $plist); + } + } + $string .= $indent2 . "\n"; + + $string .= $indent2 . " "; + $string .= $fun->Expr->toXML($plist); + $string .= " \n"; + + $string .= $indent."\n"; + + $fun->unsetArgs($plist); + + return ($string); +} + + + + + +1; diff --git a/libvcell/vcell_install/bionetgen/Perl2/HNauty.pm b/libvcell/vcell_install/bionetgen/Perl2/HNauty.pm new file mode 100644 index 0000000..0ec8e93 --- /dev/null +++ b/libvcell/vcell_install/bionetgen/Perl2/HNauty.pm @@ -0,0 +1,1010 @@ +#!/usr/bin/perl + +package HNauty; +require Exporter; + +our @ISA = qw(Exporter); +our @EXPORT = qw(HNauty deepCopy adj_permute get_adj_str); + +#our @EXPORT_OK= qw(deepCopy); +our $VERSION = 1.00; + +# NOTE: Many undeclared global symbols +#use strict; +########### HNauty program + +# list of subroutines: + +# adj_permute +# intersection +# is_discrete +# lex_ordered +# HNauty +# partition_meet +# partition_value +# pfixp +# refinement +# Run +# update_automorphisms + +#Run(); + +sub Run { + use Data::Dumper; + + my $le_part = []; + push @$le_part, [ 0, 1, 2, 3 ], [ 4, 5, 6, 7 ], [8], [9], [10]; + + my $debug_partition_value = 0; + if ($debug_partition_value) { + my $value = partition_value($le_part); + print "@$value\n"; + } + + my $le_adj = { + 0 => { 6 => [0], 7 => [0], 8 => [0] }, + 1 => { 9 => [0], 10 => [0], 11 => [0] }, + 2 => { 9 => [0], 10 => [0], 11 => [0] }, + 3 => { 6 => [0], 12 => [0], 14 => [0] }, + 4 => { 7 => [0], 12 => [0], 13 => [0] }, + 5 => { 8 => [0], 13 => [0], 14 => [0] }, + 6 => { 3 => [0], 0 => [0] }, + 7 => { 4 => [0], 0 => [0] }, + 8 => { 0 => [0], 5 => [0] }, + 9 => { 2 => [0], 1 => [0] }, + 10 => { 1 => [0], 2 => [0] }, + 11 => { 1 => [0], 2 => [0] }, + 12 => { 3 => [0], 4 => [0] }, + 13 => { 5 => [0], 4 => [0] }, + 14 => { 3 => [0], 5 => [0] } + }; + + my $adj_out = deepCopy($le_adj); + + # define adj_in - note that this example is not really directed + my ( $i, $j ); + $adj_in = {}; + for $i ( keys %$adj_out ) { + for $j ( keys %{ $adj_out->{$i} } ) { + @{ $adj_in->{$j}{$i} } = @{ $adj_out->{$i}{$j} }; + } + } + + my $the_partition = [ [ 0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14 ] ]; + + my $le_perm = { + 0 => 1, + 1 => 2, + 2 => 3, + 3 => 4, + 4 => 5, + 5 => 6, + 6 => 7, + 7 => 8, + 8 => 9, + 9 => 10, + 10 => 11, + 11 => 12, + 12 => 13, + 13 => 14, + 14 => 0 + }; + + my $debug_adj_permute = 0; + if ($debug_adj_permute) { + my $new_adj = adj_permute( $le_adj, $le_perm ); + print Data::Dumper->Dump( [$new_adj] ); + } + + my $term = [ + [1], [2], [3], [4], [5], [6], [7], [8], + [9], [10], [11], [12], [13], [14], [0] + ]; + my $c_perm = [ + [0], [1], [2], [3], [4], [5], [6], [7], + [8], [9], [10], [11], [12], [13], [14] + ]; + + my $debug_get_adj_str = 0; + if ($debug_get_adj_str) { + my $adj_infor = get_adj_str( $le_adj, $term ); + print Data::Dumper->Dump( [$adj_infor] ); + } + + my $debug_lex_ordered = 0; + if ($debug_lex_ordered) { + my $new_adj = adj_permute( $le_adj, $le_perm ); + + # print Data::Dumper->Dump([$le_adj, $new_adj]); + my $le_a = get_adj_str( $le_adj, $c_perm ); + my $le_b = get_adj_str( $new_adj, $c_perm ); + my $result = lex_ordered( $le_a, $le_b ); + print "@$result\n"; + $result = lex_ordered( [ 0, 1, 2, 2 ], [ 0, 1, 2, 2, 2 ] ); + print "@$result\n"; + $result = lex_ordered( [ 2, 1, 99 ], [ 2, 1, 0 ] ); + print "@$result\n"; + $result = + lex_ordered( [ [ 1, 2, 3, 4 ], [2] ], [ [ 1, 2, 3, 4 ], [ 1, 10 ] ] ); + print "@$result\n"; + } + + my $debug_is_discrete = 0; + if ($debug_is_discrete) { + my $result = is_discrete($c_perm); + print "$result\n"; + $result = is_discrete( [ [ 0, 1 ], [2], [3] ] ); + print "$result\n"; + } + + my $debug_intersection = 0; + if ($debug_intersection) { + my $result = intersection( [ 0, 1, 2, 3, 4, 5 ], [ 5, 1, 7, 8, 9, 0 ] ); + print "@$result\n"; + print Data::Dumper->Dump( [$result] ); + } + + my $debug_partition_meet = 0; + if ($debug_partition_meet) { + my $result = partition_meet( + [ [ 0, 1, 2, 3, 4, 5, 6, 7, 8, 9 ] ], + [ + [ [5], [ 1, 2, 3, 4, 6, 7, 8 ], [ 9, 0 ] ], + [ [ 0, 1, 2, 3 ], [ 4, 5, 6 ], [ 7, 8, 9 ] ], + [ [ 9, 0, 4, 1, 3 ], [ 2, 5, 6, 7 ], [8] ] + ] + ); + print Data::Dumper->Dump( [$result] ); + } + + my $newp = [ [ 6, 11, 7, 9, 12, 14, 8, 10, 13 ], [4], [ 1, 3, 0, 2, 5 ] ]; + my $autos = []; + my $otra_perm = { + 1 => 1, + 2 => 3, + 3 => 4, + 4 => 2, + 5 => 6, + 6 => 5, + 7 => 7, + 8 => 9, + 9 => 10, + 10 => 11, + 11 => 12, + 12 => 13, + 13 => 8, + 14 => 14, + 0 => 0 + }; + my $fix; + my $orbit_reps; + my $otra_part = + [ [0], [ 10, 2, 3 ], [1] . [ 4, 5, 6 ], [7], [ 8, 9, 11, 12, 13 ], [14] ]; + + my $debug_update_automorphisms = 0; + if ($debug_update_automorphisms) { + ( $fix, $orbit_reps, $autos ) = update_automorphisms( $autos, $le_perm ); + print Data::Dumper->Dump( [ $fix, $orbit_reps, $autos ] ); + ( $fix, $orbit_reps, $autos ) = update_automorphisms( $autos, $otra_perm ); + print Data::Dumper->Dump( [ $fix, $orbit_reps, $autos ] ); + } + + my $debug_pfixp = 0; + if ($debug_pfixp) { + ( $fix, $orbit_reps, $autos ) = update_automorphisms( $autos, $otra_perm ); + print Data::Dumper->Dump( [$autos] ); + print pfixp( $c_perm, $fix ), "\n\n"; + print pfixp( $otra_part, $fix ), "\n\n"; + } + + my $some_cell = [ 0, 1, 2, 3, 4 ]; + + my $debug_update_cell = 0; + if ($debug_update_cell) { + ( $fix, $orbit_reps, $autos ) = update_automorphisms( $autos, $le_perm ); + ( $fix, $orbit_reps, $autos ) = update_automorphisms( $autos, $otra_perm ); + print Data::Dumper->Dump( [$autos] ); + my $result = update_cell( $otra_part, $some_cell, $autos ); + print @$result; + } + + my $he_out = { + 0 => { 1 => [1], 12 => [0] }, + 1 => { 0 => [1], 14 => [0] }, + 2 => { 3 => [1], 14 => [0] }, + 3 => { 2 => [1], 13 => [0] }, + 4 => { 5 => [1], 14 => [0] }, + 5 => { 4 => [1], 15 => [0] }, + 6 => { 15 => [0], 7 => [1] }, + 7 => { 17 => [0], 6 => [1] }, + 8 => { 9 => [1], 17 => [0] }, + 9 => { 8 => [1], 20 => [0] }, + 10 => { 12 => [0] }, + 11 => { 12 => [0] }, + 16 => { 17 => [0] }, + 18 => { 20 => [0] }, + 19 => { 20 => [0] } + }; + + # define he_in + $he_in = {}; + for $i ( keys %$he_out ) { + for $j ( keys %{ $he_out->{$i} } ) { + @{ $he_in->{$j}{$i} } = @{ $he_out->{$i}{$j} }; + } + } + my $he_part = [ + [ + 0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20 + ] + ]; + my $he_perm = { + 0 => 1, + 1 => 2, + 2 => 20, + 20 => 3, + 3 => 19, + 19 => 0, + 4 => 5, + 5 => 6, + 6 => 7, + 7 => 4, + 8 => 8, + 9 => 10, + 10 => 9, + 11 => 12, + 12 => 13, + 13 => 14, + 14 => 15, + 15 => 16, + 16 => 17, + 17 => 18, + 18 => 11 + }; + + my $debug_refinement = 0; + if ($debug_refinement) { + my $result; + $result = refinement( $adj_in, $adj_out, $the_partition, $the_partition ); + print Data::Dumper->Dump( [$result] ); + print "#############\n"; + print "#############\n"; + $result = refinement( $adj_in, $adj_out, $newp, [ [4] ] ); + print Data::Dumper->Dump( [$result] ); + print "#############\n"; + print "#############\n"; + $result = refinement( $he_out, $he_in, $he_part, $he_part ); + print Data::Dumper->Dump( [$result] ); + } + + my $debug_nauty = 1; + if ($debug_nauty) { + @$result = HNauty( $adj_in, $adj_out, $the_partition ); + my $adj_a = get_adj_str( $adj_out, @$result[0] ); + print @$adj_a, "\n\n"; + + # permute + $adj_in = adj_permute( $adj_in, $le_perm ); + $adj_out = adj_permute( $adj_out, $le_perm ); + @$result = HNauty( $adj_in, $adj_out, $the_partition ); + my $adj_b = get_adj_str( $adj_out, @$result[0] ); + print @$adj_b; + $is_equal = lex_ordered( $adj_a, $adj_b ); + if ( @$is_equal[0] eq 'eq' ) { print "\nThey are equal!\n\n"; } + + # permute + $adj_in = adj_permute( $adj_in, $otra_perm ); + $adj_out = adj_permute( $adj_out, $otra_perm ); + @$result = HNauty( $adj_in, $adj_out, $the_partition ); + my $adj_c = get_adj_str( $adj_out, @$result[0] ); + print @$adj_c; + $is_equal = lex_ordered( $adj_c, $adj_b ); + if ( @$is_equal[0] eq 'eq' ) { print "\nThey are equal!\n\n"; } + + print "\n\n\nNow Hierarchical Example!!!\n"; + + $adj_in = $he_in; + $adj_out = $he_out; + $the_partition = $he_part; + $le_perm = $he_perm; + + @$result = HNauty( $adj_in, $adj_out, $the_partition ); + $adj_a = get_adj_str( $adj_out, @$result[0] ); + print @$adj_a, "\n\n"; + + # permute + $adj_in = adj_permute( $adj_in, $le_perm ); + $adj_out = adj_permute( $adj_out, $le_perm ); + @$result = HNauty( $adj_in, $adj_out, $the_partition ); + $adj_b = get_adj_str( $adj_out, @$result[0] ); + print @$adj_b; + $is_equal = lex_ordered( $adj_a, $adj_b ); + if ( @$is_equal[0] eq 'eq' ) { print "\nThey are equal!\n\n"; } + + # permute + $adj_in = adj_permute( $adj_in, $le_perm ); + $adj_out = adj_permute( $adj_out, $le_perm ); + @$result = HNauty( $adj_in, $adj_out, $the_partition ); + $adj_c = get_adj_str( $adj_out, @$result[0] ); + print @$adj_c; + $is_equal = lex_ordered( $adj_c, $adj_b ); + if ( @$is_equal[0] eq 'eq' ) { print "\nThey are equal!\n\n"; } + + } +} + +sub update_cell { + my $node = shift; #array + my $cell = shift; #array + my $perms = shift; #array + + my $i; + +# $fixing = []; + for $i ( 0 .. $#{$perms} ) { + if ( pfixp( $node, @{ @$perms[$i] }[0] ) ) { + $cell = intersection( $cell, @{ @$perms[$i] }[1] ); + } + } + return $cell; +} + +sub pfixp { + my $partition = shift; #array + my $perm_fix = shift; #array + my ( $i, $fixed ); + + $fixed = 1; + $i = 0; + while ( $fixed and $i < scalar @$partition ) { + if ( scalar @{ @$partition[$i] } == 1 + and ( not defined( $perm_fix->{ @{ @$partition[$i] }[0] } ) ) ) + { + $fixed = 0; + } + $i++; + } + return $fixed; +} + +sub update_automorphisms { + my $autos = shift; #array + my $perm = shift; #hash + + my $un_used; #hash + my $fix = {}; #hash + my $orbit_reps = []; # array + my $something; #array + my $cycle; + my ( $element, $done, $cycle_done ); + + $un_used = deepCopy($perm); + $done = 0; + while ( not $done ) { + @$something = sort keys %$un_used; + if ( scalar @$something == 0 ) { + $done = 1; + } + else { + $element = @$something[0]; + $cycle = [$element]; + $cycle_done = 0; + while ( not $cycle_done ) { + delete( $un_used->{$element} ); + $element = $perm->{$element}; + if ( not defined( $un_used->{$element} ) ) { + $cycle_done = 1; + } + else { + push @$cycle, $element; + } + } + @$cycle = sort @$cycle; + push @$orbit_reps, @$cycle[0]; + if ( scalar @$cycle == 1 ) { + $fix->{ @$cycle[0] } = 1; + } + } + } + push @$autos, [ $fix, $orbit_reps ]; + return ( $fix, $orbit_reps, $autos ); +} + +sub partition_value { + my $part = shift; #array + my $indicator; #array + my $tmp; #hash + my $other; # array + my $i; + + $tmp = {}; + for $j (@$part) { + $tmp->{ scalar @$j } += 1; + } + $indicator = []; + @$other = sort keys %$tmp; + for $j ( 1 .. @$other[ $#{$other} ] ) { + if ( defined( $tmp->{$j} ) ) { + push @$indicator, $tmp->{$j}; + } + else { + push @$indicator, 0; + } + } + return $indicator; +} + +sub preprocess { } + +sub adj_permute { + my $adj = shift; #hash adj_out + my $perm = shift; #hash + + my $new_adj; #hash + my ( $i, $j, $new_i, $new_j ); + + $new_adj = {}; + for $i ( keys %$adj ) { + $new_i = $perm->{$i}; + $new_adj->{$new_i} = {}; + for $j ( keys %{ $adj->{$i} } ) { + $new_j = $perm->{$j}; + @{ $new_adj->{$new_i}{$new_j} } = @{ $adj->{$i}{$j} }; + } + } + return $new_adj; +} + +sub get_adj_str { + my $adj = shift; #hash (adj_out) + my $part = shift; #array or $hsah + + my $perm; #hash + my $new_adj; # array + my $adj_info; # unfortunately also an array + my ( $i, $j, $value, $e, $length ); + +# $le_adj = []; + if ( ref $part eq 'ARRAY' ) { + for $i ( 0 .. $#{$part} ) { + $perm->{ @{ @$part[$i] }[0] } = $i; + } + } + else { + $perm = $part; + } + $length = ( scalar keys %$adj ) - 1; + $new_adj = adj_permute( $adj, $perm ); + for $i ( 0 .. $length ) { + for $j ( 0 .. $length ) { + if ( defined( $new_adj->{$i}{$j} ) ) { + $value = 0; + for $e ( @{ $new_adj->{$i}{$j} } ) { + $value += 2**$e; + } + push @$adj_info, $value; + } + else { + push @$adj_info, 0; + } + } + } + return $adj_info; +} + +sub lex_ordered { + + # in fact returns appropriate counter value in this case.. + my $le_primier = shift; # array + my $le_deuxieme = shift; #array + + my $tmp; #array + my ( $i, $status, $length, $result ); + + @$tmp = sort ( scalar @$le_primier, scalar @$le_deuxieme ); + $length = @$tmp[0]; + $status = ['eq']; + $i = 0; + while ( @$status[0] eq 'eq' && $i < $length ) { + if ( ref @$le_primier[$i] eq 'ARRAY' ) { + $status = lex_ordered( @$le_primier[$i], @$le_deuxieme[$i] ); + if ( @$status[0] eq 'eq' ) { + $i++; + } + } + else { + if ( @$le_primier[$i] > @$le_deuxieme[$i] ) { + @$status[0] = 'gt'; + } + elsif ( @$le_primier[$i] < @$le_deuxieme[$i] ) { + @$status[0] = 'lt'; + } + else { + $i += 1; + } + } + } + @$status[1] = $i; + return $status; +} + +sub is_discrete { + my $partition = shift; #array + + my $discrete = 1; + my $i; + + $i = 0; + while ( $discrete and $i < scalar @$partition ) { + if ( scalar @{ @$partition[$i] } > 1 ) { + $discrete = 0; + } + $i += 1; + } + return $discrete; +} + +sub intersection { + my $le_premier = shift; #array + my $le_deuxieme = shift; #array + + my ( $union, $inter, $ele, $result ); + + $union = {}; + $inter = {}; + + for $ele ( @$le_premier, @$le_deuxieme ) { + $union->{$ele}++ && $inter->{$ele}++; + } + @$result = ( keys %$inter ); + return $result; +} + +sub partition_meet { + my $the_set = shift; #array + my $partitions = shift; #array + + my $new_part; #array + my $newer_part; #array + my $p; #array + my ( $i, $j ); + my $intersection; #array + + $new_part = deepCopy($the_set); + for $p (@$partitions) { + if ( not scalar @$p == 1 ) { + $newer_part = []; + for $i (@$new_part) { + for $j (@$p) { + $intersection = intersection( $i, $j ); + if ( scalar @$intersection > 0 ) { + push @$newer_part, []; + push @{ @$newer_part[ $#{$newer_part} ] }, @$intersection; + } + } + } + $new_part = deepCopy($newer_part); + } + } + return $new_part; +} + +sub refinement { + my $adj_in = shift; #hash + my $adj_out = shift; #hash + my $ordered_partition = shift; #array + my $thecells = shift; #array + + my $cells; #array + my $equitable_partition; #array + my $cell; #hash + my $in_degree_count; #hash + my $out_degree_count; #hash + my $count; #hash + my $parts; #array + my $new_part; #array + my $index_set; #array + + my ( $cell_count, $partition_count, $v, $u, $e, $size, $t, $n ); + + #Everything is a scalar!!!!! + + $cell_count = 0; + + # need a cleen copy of cells and equitable_partition + $cells = deepCopy($thecells); + $equitable_partition = deepCopy($ordered_partition); + while ( ( not is_discrete($equitable_partition) ) + and $cell_count < scalar @$cells ) + { + + # retrieve cell from the cells + $cell = {}; + for $v ( @{ @$cells[$cell_count] } ) { + $cell->{$v} = 1; + } + $cell_count += 1; + $partition_count = 0; + while ( $partition_count < scalar @$equitable_partition ) { + if ( scalar @{ @$equitable_partition[$partition_count] } > 1 ) { + $in_degree_count = {}; + $out_degree_count = {}; + for $v ( @{ @$equitable_partition[$partition_count] } ) { + $count = {}; + for $u ( keys %{ $adj_out->{$v} } ) { + for $e ( @{ $adj_out->{$v}{$u} } ) { + if ( defined( $cell->{$u} ) ) { + $count->{$e} += 1; + } + } + } + for $e ( keys %$count ) { + if ( not defined( $out_degree_count->{$e} ) ) { + $out_degree_count->{$e}{0} = + +{ map { $_ => 1 } + @{ @$equitable_partition[$partition_count] } }; + } + $out_degree_count->{$e}{ $count->{$e} }{$v} = 1; + if ( defined( $out_degree_count->{$e}{0}{$v} ) ) { + delete( $out_degree_count->{$e}{0}{$v} ); + } + } + + # repeat for out degrees: + $count = {}; + for $u ( keys %{ $adj_in->{$v} } ) { + for $e ( @{ $adj_in->{$v}{$u} } ) { + if ( defined( $cell->{$u} ) ) { + $count->{$e} += 1; + } + } + } + for $e ( keys %$count ) { + if ( not defined( $in_degree_count->{$e} ) ) { + $in_degree_count->{$e}{0} = + +{ map { $_ => 1 } + @{ @$equitable_partition[$partition_count] } }; + } + $in_degree_count->{$e}{ $count->{$e} }{$v} = 1; + if ( defined( $in_degree_count->{$e}{0}{$v} ) ) { + delete( $in_degree_count->{$e}{0}{$v} ); + } + } + } + + # Now we make the partitions + $parts = []; + for $e ( sort ( keys %$out_degree_count ) ) { + $new_part = []; + for $size ( sort ( keys %{ $out_degree_count->{$e} } ) ) { + if ( scalar( keys %{ $out_degree_count->{$e}{$size} } ) > 0 ) { + push @$new_part, []; + push @{ @$new_part[ $#{$new_part} ] }, + ( keys %{ $out_degree_count->{$e}{$size} } ); + } + } + if ( scalar @$new_part > 1 ) { + push @$parts, []; + push @{ @$parts[ $#{$parts} ] }, @$new_part; + } + } + + # do the same for $in_degree_count + for $e ( sort ( keys %$in_degree_count ) ) { + $new_part = []; + for $size ( sort ( keys %{ $in_degree_count->{$e} } ) ) { + if ( scalar( keys %{ $in_degree_count->{$e}{$size} } ) > 0 ) { + push @$new_part, []; + push @{ @$new_part[ $#{$new_part} ] }, + ( keys %{ $in_degree_count->{$e}{$size} } ); + } + } + if ( scalar @$new_part > 1 ) { + push @$parts, []; + push @{ @$parts[ $#{$parts} ] }, @$new_part; + } + } + + # now we update the equitable partition and cells + if ( scalar @$parts > 0 ) { + if ( scalar @$parts > 1 ) { + $new_part = + partition_meet( [ @$equitable_partition[$partition_count] ], + $parts ); + } + else { + $new_part = @$parts[0]; + } + + # find smallest 't' bit here + $size = 0; + $t = 0; + for $n ( 0 .. $#{$new_part} ) { + if ( scalar @{ @$new_part[$n] } > $size ) { + $t = $n; + $size = scalar @{ @$new_part[$n] }; + } + } + + # update cells list as appropriate + for $n ( ( $cell_count + 1 ) .. $#{$cells} ) { + if ( + @{ @$cells[$n] } == @{ @$equitable_partition[$partition_count] } ) + { + push @{ @$cells[$n] }, @{ @$new_part[$t] }; + } + } + $index_set = []; + for $n ( 0 .. $#{$new_part} ) { + if ( not $n == $t ) { + push @$cells, []; + push @{ @$cells[ $#{$cells} ] }, @{ @$new_part[$n] }; + } + } + @$equitable_partition = ( + @$equitable_partition[ 0 .. $partition_count - 1 ], + @$new_part, + @$equitable_partition[ $partition_count + + 1 .. $#{$equitable_partition} ] + ); + } + + } + $partition_count += 1; + } + } + return $equitable_partition; +} + +sub HNauty { + my $adj_in = shift; #hash + my $adj_out = shift; # hash + my $node_coloring = shift; #array + + my $ordered_partition; #array + my $current_node; #array + my $cells; #array + my $tplacement; #array + my $node_indicator; #array + my $best_node; #array + my $first_terminal_node; #array + my $automorphisms; #array + my $generators; #array of hashes + my $prune_autos; #array + my $this_partition; #array + my $newset; #array + my $new_node; #array + my $some_hash; #hash + my $some_array; #array + my $new_auto; #hash + my $perm; #hash + my $fix; #array + my $orbit_reps; #array + my ( $complete, $jump_back, $search_vertex ); #Boolean + my $new_adj; + my ( $counter, $i, $j, $t, $n, $size, $vertex, $a, $b, $ntn ); + +# do some preprocessing???? +# for input: graph should vertices labeled from 0 to number vertices. Edge types +# should also be labeled from 0 on up. adj_in is hash of hash of arrays +# the hashes are keyed by vertices and the array adj_in{v1}{v2} contains the +# edge types going from vertex from v2 INTO v1. adj_out is set up similarily. + $complete = $jump_back = 0; + $best_node = $first_terminal_node = []; + $automorphisms = []; + $counter = 0; + $ntn = 0; + $ordered_partition = deepCopy($node_coloring); + push @$current_node, + refinement( $adj_in, $adj_out, $ordered_partition, $ordered_partition ); + $node_indicator = [ [] ]; + + if ( is_discrete( @$current_node[0] ) ) { + $new_adj = get_adj_str( $adj_out, @$current_node[$counter] ); + @$best_node = + ( @$current_node[$counter], @$node_indicator[$counter], $new_adj ); + $complete = 1; + } + while ( not $complete ) { + + #main loop + if ( is_discrete( @$current_node[$counter] ) ) { +# if ( $first_terminal_node == ( @$current_node[$counter], @$node_indicator[$counter], $new_adj ) ){ + if ( $first_terminal_node == [ @$current_node[$counter], @$node_indicator[$counter], $new_adj ] ){ + @$best_node = @$first_terminal_node; + } + $counter += -1; + if ( $counter < 0 ) { + $complete = 1; + } + } + elsif ( not $jump_back ) { + + # find first nontrivial cell of smallest size + $size = scalar keys %$adj_in; + $t = 0; + for $n ( 0 .. $#{ @$current_node[$counter] } ) { + if ( 1 < scalar @{ @{ @$current_node[$counter] }[$n] } + && scalar @{ @{ @$current_node[$counter] }[$n] } < $size ) + { + $t = $n; + $size = scalar @{ @{ @$current_node[$counter] }[$n] }; + } + } + @$cells[$counter] = []; + push @{ @$cells[$counter] }, @{ @{ @$current_node[$counter] }[$t] }; + @$tplacement[$counter] = $t; + @$prune_autos[$counter] = undef; + @$current_node = @$current_node[ 0 .. $counter ]; + } + else { + @$current_node = @$current_node[ 0 .. $counter ]; + } + $search_vertex = 1; + $i = 0; + while ( ( not $complete ) && $search_vertex ) { + while ( scalar @{ @$cells[$counter] } == 0 && not $complete ) { + $counter += -1; + if ( $counter < 0 ) { + $complete = 1; + } + } + if ( ( not defined( @$prune_autos[$counter] ) ) or $complete ) { + @$prune_autos[$counter] = 0; + } + else { + if ( @$prune_autos[$counter] < scalar @$automorphisms ) { + @$cells[$counter] = update_cell( + @$current_node[$counter], + @$cells[$counter], + [ + @$automorphisms[ @$prune_autos[$counter] .. $#{$automorphisms} ] + ] + ); + @$prune_autos[$counter] = scalar $#{$automorphisms}; + } + } + if ( not scalar @{ @$cells[$counter] } == 0 ) { + @{ @$cells[$counter] } = sort @{ @$cells[$counter] }; + $vertex = @{ @$cells[$counter] }[0]; + $search_vertex = 0; + } + } + if ( not $complete ) { + shift @{ @$cells[$counter] }; + $this_partition = deepCopy( @$current_node[$counter] ); + $t = @$tplacement[$counter]; + $newset = deepCopy( @$this_partition[$t] ); + $some_hash = +{ map { $_ => 1 } @$newset }; + delete( $some_hash->{$vertex} ); + @$newset = ( keys %$some_hash ); + @$this_partition = ( + @$this_partition[ 0 .. $t - 1 ], + [$vertex], $newset, @$this_partition[ $t + 1 .. $#{$this_partition} ] + ); + $new_node = + refinement( $adj_in, $adj_out, $this_partition, [ [$vertex] ] ); + @$node_indicator[ $counter + 1 ] = partition_value($new_node); + @$node_indicator = @$node_indicator[ 0 .. $counter + 1 ]; + + # number of nodes += 1 + $jump_back = 0; + if ( not scalar @$best_node == 0 ) { + $i = lex_ordered( @$node_indicator[$counter], @$best_node[1] ); + if ( @$i[0] eq 'gt' ) { +# $counter = $i[1] - 1; + $counter = @$i[1] - 1; + $jump_back = 1; + } + } + if ( not $jump_back ) { + @$current_node[ $counter + 1 ] = deepCopy($new_node); + $counter += 1; + if ( is_discrete($new_node) ) { + $ntn++; + $new_adj = get_adj_str( $adj_out, $new_node ); + if ( scalar @$first_terminal_node == 0 ) { + @$first_terminal_node[0] = deepCopy( @$current_node[$counter] ); + @$first_terminal_node[1] = deepCopy( @$node_indicator[$counter] ); + @$first_terminal_node[2] = deepCopy($new_adj); + $best_node = deepCopy($first_terminal_node); + } + else { + $i = lex_ordered( [ @$best_node[ 1 .. 2 ] ], + [ @$node_indicator[$counter], $new_adj ] ); + if ( @$i[0] eq 'lt' ) { + $best_node = deepCopy( + [ + @$current_node[$counter], @$node_indicator[$counter], + $new_adj + ] + ); + } + else { + $i = lex_ordered( @$best_node[2], $new_adj ); + if ( @$i[0] eq 'eq' ) { + + # we have found an automorphism! + $new_auto = {}; + for $i ( 0 .. $#{ @$best_node[0] } ) { + $new_auto->{ @{ @{ @$best_node[0] }[$i] }[0] } = + @{ @{ @$current_node[$counter] }[$i] }[0]; + } + push @$generators, $new_auto; + ( $fix, $orbit_reps, $automorphisms ) = + update_automorphisms( $automorphisms, $new_auto ); + $some_array = []; + for $i ( 0 .. $#{$current_node} ) { + if ( $i < $counter and pfixp( @$current_node[$i], $fix ) ) { + push @$some_array, $i; + } + } + @$some_array = sort @$some_array; + $a = @$some_array[ $#{$some_array} ]; + $jump_back = 1; + } + } + $i = lex_ordered( @$first_terminal_node[2], $new_adj ); + if ( @$i[0] eq 'eq' ) { + + # we have found an automorphism with first term node! + $new_auto = {}; + for $i ( 0 .. $#{ @$first_terminal_node[0] } ) { + $new_auto->{ @{ @{ @$first_terminal_node[0] }[$i] }[0] } = + @{ @{ @$current_node[$counter] }[$i] }[0]; + } + push @$generators, $new_auto; + ( $fix, $orbit_reps, $automorphisms ) = + update_automorphisms( $automorphisms, $new_auto ); + $some_array = []; + for $i ( 0 .. $#{$current_node} ) { + if ( $i < $counter and pfixp( @$current_node[$i], $fix ) ) { + push @$some_array, $i; + } + } + @$some_array = sort @$some_array; + $b = @$some_array[ $#{$some_array} ]; + if ($jump_back) { + @$some_array = ( $a, $b ); + @$some_array = sort @$some_array; + $counter = @$some_array[0]; + } + else { + $counter = $b; + $jump_back = 1; + } + } + elsif ($jump_back) { + $counter = $a; + } + } + } + } + } + } + $perm = {}; + for $i ( 0 .. $#{ @$best_node[0] } ) { + $perm->{ @{ @{ @$best_node[0] }[$i] }[0] } = $i; + } + + # maybe do some post processing here? + # print "number terminal nodes: $ntn\n"; + # print "number autos: ", scalar @$generators, "\n"; + return ( $perm, $generators ); +} + +sub deepCopy { + my $this = shift; + if ( not ref $this ) { + $this; + } + elsif ( ref $this eq "ARRAY" ) { + [ map deepCopy($_), @$this ]; + } + elsif ( ref $this eq "HASH" ) { + +{ map { $_ => deepCopy( $this->{$_} ) } keys %$this }; + } + else { die "what type is $_?" } +} + +1; diff --git a/libvcell/vcell_install/bionetgen/Perl2/MacroBNG2.pl b/libvcell/vcell_install/bionetgen/Perl2/MacroBNG2.pl new file mode 100755 index 0000000..5a652d6 --- /dev/null +++ b/libvcell/vcell_install/bionetgen/Perl2/MacroBNG2.pl @@ -0,0 +1,27 @@ +#!/usr/bin/perl + +use strict; +use warnings; +use FindBin; +use lib $FindBin::Bin; + +use BNGOptions; +use BNGMessages qw(error warning message); +use BNGUtils; + +#Init +my $t_begin=cpu_time(0); +our $options = new BNGOptions; +$options->GetBNGOptions(); +our $messages = new BNGMessages; +message("BioNetGen version ".BNGversion()."\n"); + +#Calculation +our $model; +eval '$model = new '.$options->config->{ModelID}; +$model->ProcessModel($options->config->{bnglfile}); +message("Processing complete.\n"); + +#Duration of calculation +my $t_end=cpu_time(0); +message(sprintf "CPU TIME: total %.2f s.\n", ($t_end-$t_begin)); diff --git a/libvcell/vcell_install/bionetgen/Perl2/MacroBNGModel.pm b/libvcell/vcell_install/bionetgen/Perl2/MacroBNGModel.pm new file mode 100644 index 0000000..8735b11 --- /dev/null +++ b/libvcell/vcell_install/bionetgen/Perl2/MacroBNGModel.pm @@ -0,0 +1,2087 @@ + # $Id: MacroBNGModel.pm,v 1.17 2006/07/27 06:43:37 faeder Exp $ +package MacroBNGModel; +##use strict; + +use Class::Struct; +use FindBin; +use lib $FindBin::Bin; +use MoleculeTypesList; +use ParamList; +use SpeciesList; +use RxnRule; +use Observable; +use BNGUtils; +use BNGModel; + + +########################################################################################################################## +my $NO_EXEC=0; # Prevents execution of functions to allow file syntax checking +my $HAVE_PS=0; # Set to 0 for MS Windows systems with no ps command - disables reporting of + # memory usage at each iteration of network generation + +my $base_model; + +# Structure containing all BioNetGen model data +struct MacroBNGModel=>{ +}; + +{ + my ($file, $line_number, $file_dat); + my %bngdata; + + sub readFile{ + our $model= shift; + our $params= (@_) ? shift : ""; + + # Internal control parameters + my $fname=""; + my $prefix=""; + $base_model= BNGModel->new(); + + # Process optional parameters + if ($params){ + for my $param (keys %$params){ + if ($param eq "no_exec"){ + $NO_EXEC=$params->{no_exec}; + } + elsif ($param eq "file"){ + $fname=$params->{file}; + $name= $fname; + $name=~ s/[.]([^.]+)$//; + $param_prefix = $name; + &pre_macr($param_prefix); + $params{file}="macr_".$fname; + } + elsif ($param eq "prefix"){ + $prefix=$params->{prefix}; + } + else { + send_warning("Parameter $param ignored"); + } + } + } + + if ($fname eq ""){ + return("Parameter file must be specified in readFile"); + } + +print "\n#################-START BASEMODEL-#####################\n"; + if ($err=$base_model->readFile(\%params)){ + exit_error($err); + } +print "\n#################-FINISH BASEMODEL-#####################\n"; + + $file = "macr_".$param_prefix.".net"; # macr_fceri_ji3.net + $params{file}=$file; # macr_fceri_ji3.net +#++++++++++++++++++++++++++++++++++++++++++ +my $entry = 'TRASH 0'; +my $slist=$base_model->SpeciesList; +$err = $slist->readString($entry,$base_model->ParamList,$base_model->MoleculeTypesList); +##$slist->print(*STDOUT, $mtlist); +#++++++++++++++++++++++++++++++++++++++++++ + &cor_net($param_prefix); # correct *.net + print WFILErec " END COR_NET \n"; + close(WFILErec); # *.rec + $filen = "macr_".$param_prefix.".bnglisx"; #macr_fceri_ji3.bnglisx + $file= "macr_".$param_prefix.".bngl"; + rename($file,$filen); + + open (WFILEbngl, ">$file") or die "Can't open $file: $!\n"; + print WFILEbngl $simul1; + close (WFILEbngl); + $params{file}=$file; # macr_fceri_ji3.bngl +# $generate_network=0; + $base_model->UpdateNet(0); + if ($err=$base_model->readFile(\%params)){ + exit_error($err); + } + return($err); + } + + +######################### +######################### +#pre_macr-begin +sub pre_macr { +my ($param_prefix) = @_; + my ($recfile, $bnglfile, $parfile, $netfile); + my ($spec2file, $rulesfile, $obserfile, $macrfile); + my ($line, $entry, $lno, $name, $suff); + my (@rab); + my (%nm_site, %nm2_site, %skf, %dpp_site, %lis1h); + my ($file, $line_number, $file_dat); + my %bngdata; + + + $bnglfile= "<${param_prefix}.bngl"; # $bnglfile= "<${param_prefix}.bngl"; + $recfile= ">macr_${param_prefix}.rec"; # $recfile= ">macr_${param_prefix}.rec"; + $parfile= ">macr_${param_prefix}.par"; # $parfile= ">macr_${param_prefix}.par"; + + open (WFILErec, $recfile) or die "Can't open $recfile: $!\n"; + open (WFILEpar, $parfile) or die "Can't open $parfile: $!\n"; + + print WFILErec $recfile,"\n"; + +READ: + print "Reading from file $bnglfile\n"; + if (!open(FH, $bnglfile)) { + return("Couldn't read from file $bnglfile: $!"); + } + $file_dat=[]; + close(FH); + my $plist= ParamList->new; + $base_model->ParamList($plist); + my $mtlist= MoleculeTypesList->new; + $base_model->MoleculeTypesList($mtlist); + while($_= get_line()){ + if (s/^\s*begin\s*//){ + $name= $_; + $name=~ s/\s*$//; + $name=~ s/\s+/ /g; + my $block_dat; + ($block_dat ,$err)= read_block_array($name); + if ($err){ last READ;} + $bngdata{$name}=1; + if ($name eq "parameters"){ + open (WFILEpar, $parfile) or die "Can't open $parfile: $!\n"; + print WFILEpar "begin parameters\n"; + for my $line (@{$block_dat}){ + my ($entry, $lno)= @{$line}; + print WFILEpar "$entry\n"; + my @tok1ens= split(' ',$entry); + my ($ind1ex, $na1m, $va1l); + if ($tok1ens[0]=~/^\d+$/){ + $ind1ex= shift(@tok1ens); # This index will be ignored + } + if (@tok1ens){ + $na1m= shift(@tok1ens); + } else { + return("No parameter name specified"); + } + if (@tok1ens){ + $va1l= shift(@tok1ens); + } else { + return("No parameter value specified"); + } + $para1ms{$na1m} = $va1l; + if ($err=$plist->readString($entry)){ + $err=errgen($err,$lno); + last READ; + } + } + printf "Read %d parameters.\n", scalar(@{$plist->Array}); + print WFILEpar "end parameters\n"; + close(WFILEpar); + } + elsif ($name=~ /^molecule[_ ]types$/){ + my $mtlist= $base_model->MoleculeTypesList; + for my $line (@{$block_dat}){ + my ($entry, $lno)= @{$line}; + if ($err=$mtlist->readString($entry,$mtlist)){ + $err=errgen($err,$lno); + last READ; + } + } + printf "Read %d molecule types.\n", scalar(keys %{$mtlist->MolTypes}); + } + elsif ($name=~ /^seed[_ ]species$/){ + my $slist= SpeciesList->new; + for my $line (@{$block_dat}){ + my ($entry, $lno)= @{$line}; + if ($err=$slist->readString($entry,$base_model->ParamList,$base_model->MoleculeTypesList)){ + $err=errgen($err,$lno); + last READ; + } + } + printf "Read %d species.\n", scalar(@{$slist->Array}); + $base_model->SeedSpeciesList($slist); + $base_model->SpeciesList($slist); + } + elsif ($name eq "species"){ + my $slist= SpeciesList->new; + for my $line (@{$block_dat}){ + my ($entry, $lno)= @{$line}; + push(@species2,$entry); + if ($err=$slist->readString($entry,$base_model->ParamList,$base_model->MoleculeTypesList)){ + $err=errgen($err,$lno); + last READ; + } + } + printf "Read %d species.\n", scalar(@{$slist->Array}); + $base_model->SpeciesList($slist); + } + elsif ($name=~ /^reaction[_ ]rules$/){ + my $nerr=0; + my @rrules=(); + for my $line (@{$block_dat}){ + my ($entry, $lno)= @{$line}; + my $nam1e = ''; + my $str1ing = $entry; + if ($str1ing=~ s/^\s*([^:].*)[:]\s*//){ + $nam1e= $1; + print "ERROR 1002 rules (user) name=$nam1e\n"; + exit; + } + elsif ($str1ing=~ s/^\s*(\d+)\s+//){ + $nam1e=$1; + } + $str1ing=~ s/^\s*//; + push(@reac1tion,$str1ing); + my $rrs; + ($rrs,$err)= RxnRule::newRxnRule($entry, $base_model->ParamList, $base_model->MoleculeTypesList); + if ($err ne ""){ + $err=errgen($err,$lno); + printf STDERR "ERROR: $err\n"; + ++$nerr; + } else { + push @rrules, $rrs; + } + } + if ($nerr){ + $err= "Reaction rule list could not be read because of errors"; + last READ; + } + $base_model->RxnRules([@rrules]); + printf "Read %d reaction rule(s).\n", scalar(@{$base_model->RxnRules}); + } + elsif ($name eq "reactions"){ + my $rlist= RxnList->new; + for my $line (@{$block_dat}){ + my ($entry, $lno)= @{$line}; + if ($err=$rlist->readString($entry,$base_model->SpeciesList,$base_model->ParamList)){ + $err=errgen($err,$lno); + last READ; + } + } + printf "Read %d reaction(s).\n", scalar(@{$block_dat}); + $base_model->RxnList($rlist); + } + elsif ($name eq "groups"){ + if (!$base_model->Observables){ + $err=errgen("Observables must be defined before Groups",$lno); + last READ; + } + my $iobs=0; + my $maxobs= $#{$base_model->Observables}; + for my $line (@{$block_dat}){ + my ($entry, $lno)= @{$line}; + my @tokens= split(' ',$entry); + # Skip first entry if it's an index + if ($tokens[0]=~ /^\d+$/){ shift(@tokens)}; + if ($iobs>$maxobs){ $err=errgen("More groups than observables",$lno); last READ;} + my $obs= $base_model->Observables->[$iobs]; + if ($tokens[0] ne $obs->Name){ + $err=errgen("Group named $tokens[0] is not compatible with any observable",$lno); + last READ; + } + shift(@tokens); + my @array= split(',',$tokens[0]); + *weights= $obs->Weights; + @weights= (0)x@weights; + my ($w, $ind); + for $elt (@array){ + if($elt=~ s/^([^*]*)\*//){ + $w=$1; + } else { + $w=1; + } + if ($elt=~ /\D+/){ + $err=errgen("Non-integer group entry: $elt",$lno); + last READ; + } + $weights[$elt]+= $w; + } + ++$iobs; + } + printf "Read %d group(s).\n", scalar(@{$block_dat}); + } + elsif ($name eq "observables"){ + my @observables=(); + for my $line (@{$block_dat}){ + my ($entry, $lno)= @{$line}; + my $str1ing = $entry; + if ($str1ing=~ s/^\s*\d+\s+//){ + } + push(@obser1vable,$str1ing); + my $obs= Observable->new(); + if ($err=$obs->readString($entry,$base_model->MoleculeTypesList)){ + $err=errgen($err,$lno); + last READ; + } + push @observables, $obs; + } + $base_model->Observables([@observables]); + printf "Read %d observable(s).\n", scalar(@{$base_model->Observables}); + } else { + $err=errgen("Could not process block type $name"); + send_warning($err); + $err=""; + } + } elsif (/^([A-Za-z][^(]*)/){ + push(@gene1rate,$_); + } else { + eval $_; + if ($@){ $err=errgen($@); last READ;}; + } + } ##while bngl + &pre_species1(\%nm_site,\%nm2_site); + &pre_rules(\%nm_site,\%nm2_site,$param_prefix,\%skf,\%dpp_site,\%lis1h); + &pre_obs1(\%nm_site,\%nm2_site,$param_prefix,\%skf,\%dpp_site,\%lis1h); + + print WFILErec " EXIT FROM sub PRE_MACR for *.rec \n"; + print WFILErec " BEGIN COR_NET \n"; + + + $macrfile= ">macr_${param_prefix}.bngl"; # $macrfile= ">macr_${param_prefix}.bngl"; + $parfile= ") { # *.par + print WFILEmacr "$line"; # macr_*.bngl + }## while + while ($line=) { # *.spec2 + print WFILEmacr "$line"; # *.macr + }## while + while ($line=) { # *.rules + print WFILEmacr "$line"; # *.macr + }## while + while ($line=) { # *.obser + print WFILEmacr "$line"; # *.macr + }## while + + close(WFILEmacr); + close(RFILEpar); + close(RFILEspec2); + close(RFILErules); + close(RFILEobser); + + for $suff ("obser","par","spec2","spec1","rules","cdat"){ + $file= "macr_${param_prefix}.$suff"; + next unless -e $file; + unlink($file)|| die "Can't DELETE : $!)"; + } +} +#pre_macr-end + +##pre_species1-begin +sub pre_species1{ +my ($nm_site, $nm2_site) = @_; + my ($entry, $name, $key, $val, $ii, $na, $va); + my (@sit); +foreach $ii (@species2) { + $name=""; $va = ''; + if ($ii=~ s/^\s*([^:].*)[:]\s*//){ + $name= $1; + print "ERROR 1001 block species (user) name=$name\n"; + exit; + } + elsif ($ii=~ s/^\s*(\d+)\s+//){ + } + + my @tok1ens= split(' ',$ii); + $entry = $tok1ens[0]; # Grb2(SH2,SH3!1).Sos(dom!1) + while ( $entry =~ s/(?:[\(])(.*?)(?:[)])//) { # select inside ( and ) + $name = $`; # L Grb2 Sos + if ( !(exists($$nm_site{$name})) ) { + @sit = ''; + @sit= split(/\,/,$1); # l l SH2 SH3!1 + foreach (@sit) { s/[!~].*//; } + foreach (@sit) { $nm_site->{$name.":".$_}++; } # L:l 2; + while(($key,$val) = each(%$nm_site)) { + if ( $key=~/:/ && $val gt 1 ) { $nm2_site->{$key} = $val; } + } + $nm_site->{$name}= scalar(@sit); # L 2 + }##if !(exists + $entry =~ s/$name\.//; + } ##while +}##foreach + return; +} +#pre_species1-end + +#pre_rules-begin +sub pre_rules{ +my ($nm_site, $nm2_site, $param_prefix, $skf, $dpp_site, $lis1h) = @_; + my ($rulesfile, $obserfile, $spec2file); + my ($line, $endl, $entry, $lno, $name, $i, $key_d);#, $endl); + my ( @lis1, @rab); + my (%site_lig); + + # ----------RULES------------- + + $rulesfile= ">macr_${param_prefix}.rules"; + open (WFILErules, $rulesfile) or die "Can't open $rulesfile: $!\n"; + print WFILErules "begin reaction_rules\n"; + @lis1 = (); + &del_blank(\@reac1tion,\@lis1); + + &hash_skf(\@lis1,$skf,$nm2_site); + &hash_sor(\@lis1,$nm2_site,$lis1h,$dpp_site); + + &hierarch_sit($dpp_site); #----prepare hierarchy set2 of variables + + &min_set($dpp_site,$lis1h,$nm_site,$nm2_site,\%site_lig); + + &trans_rec($dpp_site,$lis1h,\@lis1,\%site_lig); + print WFILErules "end reaction_rules\n"; + close(WFILErules); # *.rules +} +#pre_rules-end + +#del_blank-begin +sub del_blank{ +my ($str, $lis1) = @_; + for ( @{$str} ) { # 1 L(r) + R(l,d) <-> L(r!1).R(l!1,d) kp1, km1 14 + $_ =~ s/\#.*//; # delete comment + s/^\s{0,}//; + if (length($_)) { + if (!($_ =~ /^\s{0,}$/)) { + s/\s{0,}$//; + s/\s{1,}/ /g; + s/\s{1}/;/g; #1;L(r);+;R(l,d);<->;L(r!1).R(l!1,d);kp1,;km1 + if ( $_ =~ /^\d.*?;/ ) { + $_ = ";".$'; + } else { #;L(r);+;R(l,d);<->;L(r!1).R(l!1,d);kp1,;km1 + $_ = ";".$_; + } + push @{$lis1}, $_; #;L(r);+;R(l,d);<->;L(r!1).R(l!1,d);kp1,;km1 + } ##if2 + } ##if1 + } ##for +} +#del_blank-end + +#hash_skf-begin +sub hash_skf{ +my ($lis1, $skf, $nm2_site) = @_; + my ($rab, $reac, $prod, $key_d, ); + my ($r1, $r2, $p1, $p2, $i); + print WFILErec " from hash_skf\n"; + for (@{$lis1}) { # loop string (rules i.e.) +$testbngl =$_; + $rab = $_; #;Rec(a);+;Lig(l,l);<->;Rec(a!1).Lig(l!1,l);kp1,;km1 + $rab =~ /<->|->/; + $reac = $`; # reactants ;Rec(a);+;Lig(l,l); + $prod = $'; # products ;Rec(a!1).Lig(l!1,l);kp1,;km1 + $r1 = ""; + $p1 = ""; + $r2 = ""; + $p2 = ""; + ($r1,$r2) = split(/;\+;/,$reac); #;Rec(a); ;Lig(l,l); + ($p1,$p2) = split(/;\+;/,$prod); #;Rec(a!1).Lig(l!1,l);kp1,;km1 + &skf0($r1,$skf,$nm2_site); #;Rec(a) + &skf0($r2,$skf,$nm2_site); #Lig(l,l); + &skf0($p1,$skf,$nm2_site); #;Rec(a!1).Lig(l!1,l);kp1,;km1 + &skf0($p2,$skf,$nm2_site); + } ##for + + $i = 1; + foreach $key_d (sort keys %{$skf}) { # sorting hash on key + print WFILErec " $i $key_d "; + foreach (@{$skf->{$key_d}}) { print WFILErec " $_ "; } + print WFILErec "\n"; + $i++; + } +} +#hash_skf-end + +#inc_elt-begin +sub inc_elt{ +my ($re,$pr) = @_; + my $jj = 0; + foreach (@{$pr}) { + if ($re eq $_) { + return($jj+1); + } else { + ++$jj; + } + } + return(0); +} +#inc_elt-end + +#inc-set-begin # There are dubl-elements !!! +sub inc_set{ # check of inclusion set @re into @pr +my ($re,$pr) = @_; # @rab=@(12) @rab2=@(134) + my (@pm, $jj, $out); + @pm = @$pr; + foreach (@{$re}) { + if ( !($jj = inc_elt($_,\@pm)) ) { + return(0); # no include + } else { + $jj--; + $out = splice(@pm,$jj,1); + } + } + return(1); # include +} +#inc-set-end + # &del_set(\@rem,\@prm,\@rem_prm); +#del-set-begin # There are dubl-elements !!! +sub del_set{ # elements of rem which not into @prm +my ($rem,$prm,$rem_prm) = @_; + my (@pm, $jj, $out); + @pm = @$prm; + @$rem_prm = (); + foreach (@{$rem}) { + if ( !($jj = inc_elt($_,\@pm)) ) { + push(@{$rem_prm},$_); # no include + } else { + $jj--; + $out = splice(@pm,$jj,1); + } + } +} +#del-set-end + +=pod +#inc-set-begin +sub inc_set{ # check of inclusion set @re into @pr +my ($re,$pr) = @_; # @rab=@(12) @rab2=@(134) + my (@rm,@pm); + my %seen = (); + my @se = () ; + @rm = @$re; @pm = @$pr; @seen{@rm} = (); + delete @seen{@pm}; + @se = keys %seen; + if (@se) { + return(0); # no include + } else { + return(1); # include + } +} +#inc-set-end +=cut +#activ_sit-begin +sub activ_sit{ +my ($typrul, $reac, $prod, $mreac) = @_; + my ($name,$r1); + while($$reac) { + $$reac =~ /[\(].*?[)]/; # select (a!1) i.e. first () (r!1) + $name = $`; # name:=R A + $r1 = $name.$&; # r1:=R(a!1) from reactant A(r!1) + $$reac = $'; # .A(r!1); delete R(a!1) from reactant + $$reac =~ s/^(?:[;+.])*//; # A(r!1); + if ( $$prod =~ /\Q$r1\E/ ) { + push(@$mreac,$r1); # R(a!1) from $reac to array A(r!1) + } else { + push(@$mreac,$r1); # R(a!1) from $reac to array A(r!1) + } + } ## while($reac) +} +#activ_sit-end + +#hierarch_sit-begin +sub hierarch_sit{ +my ($dpp_site) = @_; + my ($fl, $key, $name, $keyold, $bsite, $keyr, $iter); + my (@a, @b, @bb, @c); + my (%tab_site, %m_kv); + + $fl = 1; + $iter = 1; + while($fl) { + %m_kv = %$dpp_site; + $fl=0; + foreach $key (keys %m_kv) { # Lyn:SH2; Lyn:U; + %tab_site = (); + @bb = (); + @b = @{$m_kv{$key}}; # SH2 U SH2 U + ($name,$keyold) = split(/\:/,$key); # Lyn:SH2 + foreach (@b) { # SH2 U; SH2 U; + $tab_site{$_} = 1; # SH2->1 U->1 + } + for $bsite (@b) { # SH2 U + $keyr = $name.':'.($bsite); # Lyn:SH2 + if ( @{$m_kv{$keyr}} ) { + @a = @{$m_kv{$keyr}}; # set @a=SH2 U + foreach (@a) { + if (!$tab_site{$_}) { + $tab_site{$_} = 1; + push(@bb,$_); # SH2 U + $fl = 1; + } + } ##@a + } ##if + } ##@b + push(@b,@bb); # SH2 U + @{$m_kv{$key}}=@b; # SH2 U + delete $dpp_site->{$key}; # Lyn:SH2 Lyn:U + @c = sort sort {$a<=>$b} @b; + @{$dpp_site->{$key}} = @c; # (13456) + } #foreach $key + print WFILErec " iteration $iter dpp_site sort key of variable (n/n hierarch_sit)\n"; + foreach $key (sort keys %{$dpp_site}) { + print WFILErec " $key @{$dpp_site->{$key}}\n"; + } + $iter++; + } ##while +} +#hierarch_sit-end + +#min_set-begin +sub min_set{ #----prepare minimal set of variables +my ($dpp_site, $lis1h, $nm_site, $nm2_site, $site_lig) = @_; + my ($key, $name, $si1,, $si2, $key2, $name2, $fl, $ii, $r1, $r2); + my (@key_del, @rabm, @rab2); + my %f_obr = (); + @rabm = keys(%{$dpp_site}); + $fl = scalar(@rabm); + $ii = 0; + @key_del = (); # key of string which will delete into @m_kv1 + while ( ($key,$r1) = each(%{$dpp_site}) ) { + $ii++; + if ( $f_obr{$key} ) { next; } + $f_obr{$key} =1 ; + ($name,$si1) = split(/\:/,$key); # S:site3 A r + while ( ($key2,$r2)=each(%{$dpp_site}) ) { + if ( $f_obr{$key2} ) { next; } + ($name2,$si2) = split(/\:/,$key2); + if (($name eq $name2)&&($key ne $key2)) { + if ( ($#$r1 == $#$r2) && ($si1 eq "%" || $si2 eq "0") ) { + if (&inc_set($r1,$r2) && ($si1 eq "%")) { push(@key_del,$key); next; } + if (&inc_set($r2,$r1) && ($si2 eq "%")) { push(@key_del,$key2); next; } + } else { + if (&inc_set($r1,$r2)) { push(@key_del,$key); next; } + if (&inc_set($r2,$r1)) { push(@key_del,$key2); next; } + } + } ##if name + } ##foreach2 dpp_site + keys %$dpp_site; + if ($ii == $fl) { last; } + } ##foreach1 dpp_site + foreach (@key_del) { + delete $dpp_site->{$_}; + } + while ( ($key,$r1) = each(%$dpp_site) ) { + ($key2,$ii) = split(/\:/,$key); + @rabm = @{$dpp_site->{$key}}; + if ( ($nm_site->{$key2}) == ($#rabm+1) ) { + delete $dpp_site->{$key} ; + } + } ## while + print WFILErec " MINIMUM set of variable (n/n min_set)\n"; + foreach $key (sort keys %{$dpp_site}) { + print WFILErec " $key, @{$dpp_site->{$key}}\n"; + ($name,undef) = split(/\:/,$key); # S:site3 + @rabm = (); + @rabm = @{$dpp_site->{$key}}; # site1 site3 + foreach(@rabm) { ++$$site_lig{$name.":".$_};} + } + print WFILErec " hash site_lig. \n"; + if ( !(%$dpp_site) ) { print " REDUCTION NO\n"; exit; } + foreach $key (sort keys %{$site_lig}) { + if ( $site_lig->{$key} > 1 ) { + print WFILErec " $key, $site_lig->{$key}\n"; + } else { + delete $site_lig->{$key}; + } + } + @rabm = keys %{$site_lig}; + print WFILErec " hash lis1h. \n"; + foreach $key (sort keys %{$lis1h}) { + if ( &inc_elt($key,\@rabm) ) { + print WFILErec " $key, @{$lis1h->{$key}}\n"; + } else { + delete $lis1h->{$key}; + } + } + print WFILErec " Macro rules (n/n trans_rec)\n"; +} +#min_set-end + +#num_site-begin +sub num_site{ +my ($re, $pr, $nm2_site, $dep_sit) = @_; + my ($is, $ii, $ss, $name, $eqv); + my (@rem, @prm, @res, @aonly); + my (%seen); + $eqv = 0; + if ( $re eq $pr) { $eqv = 1;} + $re =~ /(?:[\(])(.*)(?:[)])/; # select into ( and ) Lig(l,l) from reactant + $name = $`; # Lig + $ss= $1; # l,l + @rem= split(/\,/,$ss); # l l + $pr =~ /(?:[\(])(.*)(?:[)])/; # Lig(l!1,l) + $ss = $1; # select into ( and ) Lig(l!1,l) from product + @prm= split(/\,/,$ss); # l!1 l + @res = @rem; # l l + foreach (@res) { s/[!~].*//; } # select name site l l + %seen = (); @aonly = (); + foreach $ii (@res) { + push(@aonly,$ii) unless $seen{$ii}++; # delete dubl l l => l + } + if ( $eqv ) { @$dep_sit = @aonly; $ii = "%"; return($ii); } + if ( $#res != $#aonly ) { + for ($ii=0;$ii<=$#rem;$ii++) { + ($rem[$ii],$prm[$ii]) = ($prm[$ii],$rem[$ii]); # rem=l!1 l prm=l l + } + } + foreach (@aonly) { # l + if ( defined($nm2_site->{$name.":".$_}) ) { # Lig:l + for ($ii=2;$ii<=$nm2_site->{$name.":".$_};$ii++) { + push(@rem,$_.":".$ii); # l!1 l adding r:2 => l!1 l l:2 + push(@prm,$_.":".$ii); # l l adding r:2 => l l l:2 + } + } + } + &del_set(\@rem,\@prm,\@aonly); # there are dubl !!! +## %seen = (); @seen{@rem} = (); # search elements from $rem which not into @prm +## delete @seen{@prm}; # delete from @rem keys from @prm +## @aonly = keys %seen; # only keys rem-prm = l!1 wich changed + if ( $#aonly != 0 ) { + print STDERR "ERROR 1003: aonly= $#aonly reactant=$re product=$pr \n"; + exit; + } + $ii = $aonly[0]; # l!1 + @prm = (); + push(@prm,$ii); # activnyi site l!1 + &del_set(\@rem,\@prm,\@aonly); # there are dubl +## %seen = (); # search elements from $rem which not into @prm +## @seen{@rem} = (); # creat tabl view dependence site +## delete @seen{@prm}; # delete from dependence sites one activny site +## @aonly = keys %seen; # only keys rem-prm=l l:2 + foreach (@aonly) { s/[!~].*//; } # select name site + @$dep_sit = @aonly; #l l:2 # depended sites without activ_site + $ii =~ s/[!~].*//; #l!1=>l # select name site + push(@$dep_sit,$ii); #l l:2 l # add activ_site + %seen = (); @res = (); + foreach $ii (@$dep_sit) { push(@res,$ii) unless $seen{$ii}++; } # l l:2 delete dubl + @$dep_sit = @res; # l l:2 + return($ii); # l=name of site of reaction +} +#num_site-end + +#hash_sor-begin +sub hash_sor{ +my ($lis1, $nm2_site, $lis1h, $dpp_site) = @_; + my ($rab, $name, $reac, $prod, $coef, $n_site, $uni); + my ($key_dubl, $key_d, $key_l, $ind, $r1, $p1, $i, $typrul); + my (@mreac, @mprod, @dep_sit, @rxd, @lis_sit, @rxl); + print WFILErec " for hash lis1h (n/n hash_sor)\n"; + $ind = -1; + $uni=1; + for (@{$lis1}) { # loop rules + $ind++; + $rab = $_; #;R(a!1).A(r!1);->;R(a);+;A(r);kmS #;Rec(a);+;Lig(l,l);<->;Rec(a!1).Lig(l!1,l);kp1,;km1 + $rab =~ s/^;//; #R(a!1).A(r!1);->;R(a);+;A(r);kmS #Rec(a);+;Lig(l,l);<->;Rec(a!1).Lig(l!1,l);kp1,;km1 + $rab =~ /<->|->/; # <-> or -> separation + $reac = $`; # reactants R(a!1).A(r!1); + $prod = $'; # products ;R(a);+;A(r);kp2,;km1 + $prod =~ /.*\);/; + $prod =$&; # ;R(a);+;A(r); + $coef = $'; # kms # kp2,;km1 + @dep_sit=(); + @lis_sit=(); + @mreac = (); + @mprod = (); + $r1 = ""; + $p1 = ""; + $typrul = 0; + if ($prod =~ /;\+;/) { $typrul = 1;} + &activ_sit($typrul,\$reac,\$prod,\@mreac); # 1,R(a!1).A(r!1);, ;R(a);+;A(r);, blank + for (@mreac) { + $r1 = $_; #R(a!1) A(r!1) # Rec(a) or Lig(l,l) + $_ =~ /\(/; # select ( + $name = $`; #R # name:=Rec or Lig + $prod =~ /\Q$name\E[\(].*?[)]/; #R(a) # Rec(...) + $p1 = $&; #p1=R(a) from product # p1:=Rec(a!1) or Lig(l!1,l) + $prod =~ s/\Q$p1\E//; # delete R(a) from product + push(@mprod,$p1); #R(a) # Rec(a!1) from $prod to array + $n_site = &num_site($r1,$p1,$nm2_site,\@dep_sit); # R(a!1) R(a) -> a + if ( $n_site eq "%" ) { + $n_site = "%".$uni; + $uni++; + } + @lis_sit=(); + push(@lis_sit,$ind); # hash matrix->key=number of string + @rxd = (); + @rxl = (); + $key_dubl = ""; + $key_d = $name.':'.$n_site; # R:a + if ( exists($$nm2_site{$key_d}) ) { + $key_dubl = $name.':'.$n_site.":2"; # L:l:2 + } + $key_l = $key_d; # R:a + if ( @{$dpp_site->{$key_d}} ) { + @rxd = @{$dpp_site->{$key_d}}; # a b g + } + foreach (@rxd) { # a b g + if (!&inc_elt($_,\@dep_sit)) { push(@dep_sit,$_) } + } + @{$dpp_site->{$key_d}} = @dep_sit; + if ( @{$lis1h->{$key_l}} ) { + @rxl = @{$lis1h->{$key_l}}; + } + foreach (@rxl) { + if (!&inc_elt($_,\@lis_sit)) { push(@lis_sit,$_) } + } + @{$lis1h->{$key_l}} = @lis_sit; + print WFILErec " $key_l "; # Rec:a + foreach (@lis_sit) { print WFILErec " $_ "; } # 0 n-string into rules + print WFILErec " $$lis1[$ind]\n"; # ;Rec(a);+;Lig(l,l);<->;Rec(a!1).Lig(l!1,l);kp1,km1 + if ($key_dubl) { + print WFILErec " $key_dubl "; # L:l:2 + foreach (@lis_sit) { print WFILErec " $_ "; } # 0 n-string into rules + print WFILErec " $$lis1[$ind]\n"; # ;Rec(a);+;Lig(l,l);<->;Rec(a!1).Lig(l!1,l);kp1,km1 + } + } ##for @mreac + if ($#mreac != $#mprod) { + print "ERROR: 1004 n_mreac= $#mreac : n_mprod= $#mprod \n"; + exit; + } + } ## @$lis1 for hash + + print WFILErec " sort hash dpp_site (n/n hash_sor)\n"; + $i=1; + foreach $key_d (sort keys %{$dpp_site}) { # sorting hash on key + print WFILErec " $i $key_d "; + foreach (@{$dpp_site->{$key_d}}) { print WFILErec " $_ "; } + print WFILErec "\n"; + $i++; + } +} +#hash_sor-end + +#add_skf-begin +sub add_skf{ # @list r r input +my ($skf1, $skf2, $sit1, $skf, $nm2_site) = @_; # @dub r 2 output + my ($key, $ii); + my (@rabm); + @rabm = (); + $key = $skf1.":".$skf2; # L:R + if ( defined($skf->{$key}) ) { + @rabm = @{$skf->{$key}}; + if ( !(&inc_elt($sit1,\@rabm)) ) { # r + push(@{$skf->{$key}},$sit1); # L:R r + } + } else { + push(@{$skf->{$key}},$sit1); # L:R r + } + if ( defined($nm2_site->{$skf1.":".$sit1}) ) { # L:r + for ($ii=2;$ii<=$nm2_site->{$skf1.":".$sit1};$ii++) { + push(@{$skf->{$key}},$sit1.":".$ii); # L:R r r:2 + } + } +} +#add_skf-end + +#skf0-begin +sub skf0{ #processing of links +my ($rp1, $skf, $nm2_site) = @_; #;Rec(a!1).Lig(l!1,l) + my ($p1, $skf1, $skf2, $sit1, $sit2, $lnk1, $lnk2, $lef1, $rit1, $lef2, $rit2); + my (@rabm); + + $p1 =$rp1; #;R(b~pY!2).A(s).P(s!2);k3,;k_3 + while($p1 =~ /!/) { #;R(b~pY!1!2).A(s!1).P(s!2);k3,;k_3 + $lef1 = $`; #;R(b~pY ;Rd(Y~pY + $rit1 = $'; #1!2).A(s!1).P(s!2);k3;k_3 + $rit1 =~ /[,)!]/; #1!2).A(s!1).P(s!2);k3;k_3 + $lnk1 = "!".$`; #!1 lnk1*** + if ( ($` eq "+") || ($` eq "?") ) { # (visjak + and ?) + $p1 =~ s/\Q$lnk1\E//; #;R(b~pY!2).A(s!1).P(s!2);k3,;k_3 + next; + } + $lef1 =~ /.*[,\(]/; #;R(b~pY + $skf1 = $&; #;R( ;Rd( + $sit1 = $'; #b~pY Y!1!2 + $sit1 =~ s/[~!].*//; #b Y + $skf1 =~ s/.*[\.;]//; #R( Rd( + $skf1 =~ s/\(.*//; #R Rd + $p1 =~ s/\Q$lnk1\E//; #;R(b~pY!2).A(s!1).P(s!2);k3,;k_3 + if (!($p1 =~ /\Q$lnk1\E/)) { # bob? (visjak?) + next; + } + $lef2 = $`; #;R(b~pY!2).A(s + $rit2 = $'; #).P(s!2);k3,;k_3 + $lnk2 = $lnk1; #!1 lnk2*** + $lef2 =~ /.*[,\(]/; #;R(b~pY!2).A(s + $skf2 = $&; #;R(b~pY!2).A( + $sit2 = $'; #s + $sit2 =~ s/[~!].*//; #s + $skf2 =~ s/.*[\.;]//; #A( + $skf2 =~ s/\(.*//; #A + $p1 =~ s/\Q$lnk2\E//; #;R(b~pY!2).A(s).P(s!2);k3,;k_3 + &add_skf($skf1,$skf2,$sit1,$skf,$nm2_site); # R:L l + $lef1 =""; + &add_skf($skf2,$skf1,$sit2,$skf,$nm2_site); # L:R r r:2 + $lef1 =""; + } ##while p1 +} +#skf0-end + +#cor_net-begin +sub cor_net{ +my ($param_prefix) = @_; +my ($recfile,$netfile,$rabfile,$namenet,$namerab,$linen,$rec,$linei,$line); +my ($nn,$fl,$tei1,$out,$endl,$key,$ii,$jj,$r1,$r2,$fm1,$fm2,$fs1,$fs2,$file,$suff); +my ($fli,$r1i,$r2i,$fm1i,$fm2i,$fs1i,$fs2i,$n_subtracts,$n_adds,$s1,$s2,$s3,$nk); +my ($foun,$nnn,$s1n,$s3n,$nkn,$an,$bn,$ns1,$ns2,$li1,$li2,$si1,$m1,$si2,$m2); +my ($foui,$nni,$s1i,$s3i,$nki,$ai,$bi); +my (@rabn,@rr1,@rr2,@val,@reac); +my (@rabi,@rr1i,@rr2i); +my (%ms,%ms1,%ms2,%master,%slive,%croc,%rmaster,%rslive); +my (%m_spe,%s_spe,%rea_l,%rea_r,%rrea_l,%rrea_r,%dubl); + %ts3n = (); + @species = (); + + $recfile= " ) { + if ( ($line =~ / MINIMUM set/) ) { + $fl=1; next; + } + elsif ( ($line =~ / hash site_lig./) ) { + $fl=0; last; + } + elsif ( $fl ) { # work line + $line =~ s/^\s+//; # A:a1, a1 r A:a2, a2 r + ($tei1,$rec) = split(/\:/,$line,2); # tei1=A rec=a1, a1 r + @rabn = (); + (undef,@rabn) = split(/\s+/,$rec); # rabn =a1 r (depend sites and activ site + $out = ""; + $out = $tei1.$rabn[0]."_"; #Aa1_ + foreach(@rabn) { + if(!($_ eq $rabn[0])) { $out .= $_."_"; } #Aa1_r_ + } + chop($out); #Aa1_r + push(@{$croc{$out}},@rabn); # Aa1_r = (a1 r) nabor sites + if ( exists($master{$tei1}) ) { + push(@{$slive{$tei1}},$out) ; # key=A; value=Aa2_r SLIVE + } else { + $master{$tei1} = $out ; # key=A; value=Aa1_r MASTER + } + next; # next line from dpp_site + } + else { + next; + } + } ## whileREC + close(RFILErec); #########1 + + %rmaster = reverse(%master); + %rslive = (); + while( ($key,$rec) = each(%slive) ) { + @rslive{@$rec} = ($key) ; + } + %ms1 = (); %ms2 = (); + while( ($key,$rec) = each(%rmaster) ) { + $ms1{$key}=$rec; + } + while( ($key,$rec) = each(%rslive) ) { + $ms1{$key}=$rec; + } + %ms2 = %ms1; + %ms = %ms1; + + #adaptation *.net ###########2 + + $rabfile= "macr_${param_prefix}.rab"; + $netfile= "macr_${param_prefix}.net"; + open (RFILEnet, "<", $netfile) or die "Can't open $netfile: $!\n"; + open (WFILErab, ">", $rabfile) or die "Can't open $netfile: $!\n"; + + while ( $line= ) { # search-copy "begin molecule types" + if ( $line =~ /begin molecule types/ ) { + print WFILErab "$line"; + last; + } else { + print WFILErab "$line"; + } + } ## whileNET + $ii = 0; + while ( $line= ) { # work molecule types + if ( $line =~ /end molecule types/ ) { + $ii++; + $fm1 = sprintf "%3d %s\n", $ii, "TRASH"; + print WFILErab "$fm1"; + print WFILErab "$line"; + last; + } else { + print WFILErab "$line"; $ii++; + } + } ## whileNET + + #preparation %m_spe %s_spe ###############3 + + while ( $line= ) { # search-copy "begin species" + if ( $line =~ /begin species/ ) { + print WFILErab "$line"; + last; + } else { + print WFILErab "$line"; + } + } ## whileNET + + #preparation %m_spe %s_spe ###############3 + + @species=(); $ii = 0; + while ( $line= ) { # WORK SPECIES_macr + if ( $line =~ /end species/ ) { + $ii++; + $fm1 = sprintf "%5d %s\n", $ii, "TRASH 0"; + print WFILErab "$fm1"; + print WFILErab "$line"; + last; + } else { + print WFILErab "$line"; $ii++; + chomp($line); + $line =~ s/^\s+// ; #3 Sykl_tSH2(l~Y,tSH2) Syk_tot + ($ns1,$li1,undef) = split(/\s+/,$line); #3 Sykl_tSH2(l~Y,tSH2) Syk_tot + push(@species,$li1); #Sykl_tSH2(l~Y,tSH2) + } ##if + } ## whileNET + # @species good ##############4 @rr1 @rr2 %ms1 + + while ( $line= ) { + if ( $line =~ /begin reactions/ ) { + print WFILErab "$line"; + last; + } else { + print WFILErab "$line"; + } + } ## whileNET + + @reac = (); + while ( $line= ) { + if ( $line =~ /end reactions/ ) { + $endl = $line; + last; + } else { + push(@reac,$line); # full reac + } + } ## input reactions + #################5 update reactions + $nn = -1; + foreach $linen ( @reac ) { + $nn++; + if ( $nn == 0 ) { $reac[$nn] = $linen; next; } + if ( !($linen =~ /\,/) ) { + $reac[$nn] = $linen; + }else { + @rr1 = (); @rr2 = (); @rabn = (); + $line =$linen; + $line =~ s/^\s+//; # 27 14 20 km1 + chomp($line); + ($r1,$r2) = split(/\,/,$line); #29 20 4,18 kmS or #30 5,17 11 kpS + @rr1 = split(/\s+/,$r1); #29 20 4 #30 5 + @rr2 = split(/\s+/,$r2); #18 kmS #17 11 kpS + push(@rabn,@rr1); + push(@rabn,@rr2); + if ($#rr1 == 1) { ####LEFTvariant - 30 5,17 11 kpS + ($nnn,$an,$bn,$s3n,$nkn) = @rabn; + $n_adds = 0; %dubl = (); + for ( $ii=0; $ii<$nn; $ii++ ) { + @rr1i = (); @rr2i = (); @rabi = (); + if ($n_adds == 2) { %dubl = (); last; } # out from + $linei = $reac[$ii]; # read from 11 #####RIGHT + }##else if (",") + } ## foreach NET reactions + for ( $ii=0; $ii<=$nn; $ii++ ) { # output $reac to *.rab + print WFILErab "$reac[$ii]"; + } + print WFILErab "$endl"; # end reactions + + #################6 update droup +##@obser1vable +=pod + foreach( ($key,@rabm) = %ts3n ) { # prepare update GROUPS + $egf = $species[$key-1]; # egf(r) $key=1 @rabm=9,15,25,37,45,46 + $egf =~ s/\(.*//; # egf + my $jj = ''; + foreach $ii ( @obser1vable ) { + if ( $ii =~ /;$egf$/ ) { #;Molecules;egf_tot;egf + if ( $ii =~ /Molecules;(.*?);/ ) { + @egf_tot{$1} = @rabm; # %egf_tot + last; + } + } ## if egf + } ##for $ii @obser + } ##foreach ts3n +=cut +{ +my ($an, $bn, $key, $egf, $egfr1148, $jj); + foreach( ($key,undef) = %ts3n ) { # prepare update GROUPS + my ($an,$bn) = split(".",$key); + $egf = $species[$an-1]; # egf(r) from 1 species + $egfr1148 = $species[$bn-1]; # egfr1148(...) from 5 spesies + $egf =~ s/\(.*//; # egf + $egfr1148 =~ s/\(.*//; # egfr1148 + $jj = ''; + foreach $ii ( @obser1vable ) { + if ( $ii =~ /;$egf$/ ) { #;Molecules;egf_tot;egf + if ( $ii =~ /Molecules;(.*?);/ ) { + $egf_tot{$1} = @rabm; # %egf_tot + last; + } + } ## if egf + } ##for $ii @obser + } ##foreach ts3n +} + while ( $line= ) { + if ( $line =~ /begin groups/ ) { + print WFILErab "$line"; + last; # begin groups + } else { + print WFILErab "$line"; + } + } ## whileNETbefore_group + while ( $line= ) { + if ( $line =~ /end groups/ ) { # end groups + print WFILErab "$line"; + last; + } else { + (undef,$name_group,undef) = split(' ',$line); + if ( exists($egf_tot{$name_group}) ) { # update GROUPS + @rabm =@{$egf_tot{$name_group}}; # 9,15,25,37... + foreach ( @rabm ) { # 9,15,25,37... + $line =~ s/$_,|$_//; + } + } ## exists egf_tot + print WFILErab "$line"; ##@obser1vable + } + } ## whileNETafter_group + close(RFILEnet); + close(WFILErab); +rename($netfile,$netfile."isx"); +rename($rabfile,$netfile); +} ## cor_net +#cor_net-end + +#trans_rec-begin +sub trans_rec{ #---transform micro to macro(reactions) +my ($dpp_site, $lis1h, $lis1, $site_lig) = @_; + my ($lin, $value, $val, $ind, $ino, $re_lin); + my (@li); + + $re_lin = ""; + $ino = 0; + $ind = -1; + foreach $value (@{$lis1}){ #;Lig(l!1,l!2).Lyn(U!3,SH2).Rec(a!2,b~Y!3).Rec(a!1,b~Y); + $ind++; + @li = (); + &r_mac($dpp_site,$lis1h,$value,$site_lig,$ind,\@li); # @li=;Ssit1_site2(site1);+;K(s)... + if (@li) { #$site_lig =S:site1 + foreach $val (@li) { #$val=;Ssite1_site2(site1);+;K(s);... + $ino++; + $lin = $ino.$val; #10;Ssite1_site2(site1);+;K(s);<->;Ssite1_site2(site1!1).K(s!1);k1;k_1 + $lin =~ s/;/ /g; #10 Ssite1_site2(site1) + K(s) + print WFILErec "$lin\n"; + print WFILErules "$lin\n"; + } + } else { + $ino++; + $lin = $ino.$value; #10;Ssite1_site2(site1);+;K(s);<->;Ssite1_site2(site1!1).K(s!1);k1;k_1 + $lin =~ s/;/ /g; #10 Ssite1_site2(site1) + K(s) + print WFILErec "$lin\n"; + print WFILErules "$lin\n"; + } + }##for value +} +#trans_rec-end + +#trans_obs-begin +sub trans_obs{ #---transform micro to macro(OBSERVABLES) +my ($dpp_site, $lis1h, $lis1, $skf) = @_; + my ($lin_mac,$rr,$group_type,$group_name); + my ($mol,$mol_form,$n_form,$nobj_form); + my (@re,@formula,@formulas); + + $nobj_form = 1; + foreach (@{$lis1}) { # line from observables + $lin_mac=""; + $mol_form=""; + (undef,$group_type, $group_name, @re) =split(/\;/,$_); #;Molecules;RecMon;Rec(a);Rec(a!1).Lig(l!1,l) + $lin_mac = $group_type.";".$group_name." "; #;Molecules;RecMon ;Molecules;SA OLD $lin_mac = $group_type.";+".$nobj_form."_0:".$group_name.$lin_mac; + # Validate $group_name + if (!($group_name=~/^[A-Za-z]/)){ + $_ =~ s/;/ /g; + &exit_error("Invalid group name. Must start with a letter.",$_); + } + for $rr (@re){ #Rec(a) Rec(a!1).Lig(l!1,l) Lyn(U,SH2) S.A from one string observables + if( !($rr =~ /\(/ )) { + $lin_mac .= &obs_mac0($rr, $dpp_site, $lis1h, $skf).";"; #Rec.Rec S.A => Ssite1_site2.A + } else { + $rr =~ /\(/; #Rec(a) Rec(a!1).Lig(l!1,l) Lyn(U,SH2) + keys %{$dpp_site}; # begin hash + $mol = ""; + &obs_mac($rr, $dpp_site, $lis1h, \$mol, \$mol_form, $skf); #Rec(a) Rec(a!1).Lig(l!1,l) Lyn(U,SH2) + if($mol){$lin_mac .= ";".$mol}; + } ##if + } ##$rr + if ($mol_form){ # formulas + $lin_mac .= ";"; + $lin_mac =~ s/;/ /g; + chop($mol_form); + @formulas = split(/\#/,$mol_form); + foreach (@formulas){ + $n_form = 1; + @formula = split(/\&/,$_); + foreach (@formula){ + $lin_mac .= $_."&"; # $lin_mac = $group_type.";*".$nobj_form."_".$n_form.":".$group_name.";".$_; + ++$n_form; + } ##formula + ++$nobj_form; + $lin_mac = "#".$lin_mac; + chop($lin_mac); + chop($lin_mac); + print WFILErec $lin_mac; + print WFILEobser $lin_mac; + $lin_mac = " "; + } ##formulas + print WFILErec "\n"; + print WFILEobser "\n"; + } else{ + $lin_mac =~ s/;/ /g; + print WFILErec $lin_mac; + print WFILErec "\n"; + print WFILEobser $lin_mac; + print WFILEobser "\n"; + } + } ##lis1 +} +#trans_obs-end + +#r_mac-begin +sub r_mac{ +my ($dpp_site, $lis1h, $value, $site_lig, $ind, $li) = @_; + my ($out, $val, $aft, $lig, $fl, $key, $tei1, $tei2, $rnam); + my (@re, @rabm, @rabms, @rabmn, @lir); + my (%rdep, %rlig); + + %rlig = %{$site_lig}; + %rdep = %{$dpp_site}; + $lig = 0; +mlig: + $fl = 0; + $val = $value; #R(l!+,a);+;A(r);->;R(l!+,a!1).A(r!1);kpS#;Rec(g~pY);+;Syk(tSH2);<->;Rec(g~pY!1).Syk(tSH2!1);kpS,;kmS + foreach $key (sort keys %rdep) { # A:a1, a1 r A:a2, a2 r # Syk:a_a_tSH2 Syk:l_l_tSH2 + ($tei1,undef) = split(/\:/,$key); # tei1=A + if ( !($val =~ /[;\.]\Q$tei1\E\(/) ) { + next; # no Macro ;A( and .A( + } + @rabms = (); + @rabm= sort @{$rdep{$key}}; # rabm =a1 r (depend sites and activ site + foreach ( @rabm) { push(@rabms,$tei1.":".$_); } # @rabms=A:a1 A:r + $out = ""; + while ( $val =~ /[;\.]\Q$tei1\E\(/ ) { # is ;A( or .A( + @re = (); + $tei2 = $&; #;A( + $val = $'; #r);->;R(l!+,a!1).A(r!1);kpS #;<->;Rec(g~pY!1).Syk(tSH2!1);kpS,;kmS + $out .= $`; #R(l!+,a);+ #;Rec(g~pY);+ + $' =~ /\)/; #r #tSH2 a!2,b~Y!3 + @re = split(/\,/,$`); #r #tSH2 a!2 b~Y!3 + foreach (@re) { s/[!~].*//; } #r #tSH2 a b select name site + if ( !(&inc_set(\@re,\@rabm)) ) { # @re(tSH2) site include @rabm(a tSH2)? + $out .= $tei2; # no + next; + } + $fl = 1; + chop($tei2); #;Syk + $out .= $tei2.$rabm[0]."_"; #;Rec(g~pY);+;SyktSH2_ + foreach(@rabm) { + if(!($_ eq $rabm[0])) { $out .= $_."_"; } #;SyktSH2_a !! a tSH2 + } + chop($out); #;Syka_tSH2 + $out .= '('; #;Syka_tSH2( + $val =~ /\)/; #tSH2 a!2,b~Y!3) + $out .= $`.")"; #;Syka_tSH2(tSH2) ;Reca_b(a!2,b~Y!3) + $val = $'; #;<->;Rec(g~pY!1).Syk(tSH2!1);kpS,;kmS + } ##while + foreach $aft (keys %{$lis1h}) { # Syk:tSH2 + if ( &inc_elt($aft,\@rabms) ) { # @rabms=Syk:l Syk:tSH2 + @rabmn = @{$lis1h->{$aft}}; # 0, 2, 10 - $ind string rules + if ( &inc_elt($ind,\@rabmn) ) { + delete $rdep{$key}; # Syk:l + if ( $value =~ /;\+;.*->;/ ) { #;Reca_g(g~pY);+;SyktSH2_l(tSH2);<-> + if ( ($rlig{$aft} > 0)&&($lig==0) ) { # 2 + $lig = 1; # dalee $K(s) + } else { #add #;Reca_g(g~pY);+;SyktSH2_l(tSH2);<-> + @re = split(/\:/,$aft); #Syk:tSH2 + $tei1 = $re[0].$re[1]; #SyktSH2 + @re = split(/;\+;/,$out); #;Reca_g(g~pY) !! SyktSH2_l(tSH2);< + $out = $re[0].";+;".$re[1]; #;$Reca_g(g~pY);+;SyktSH2_l(tSH2);<-> + } + --$rlig{$aft}; # 2-1=> 1 + if(!($rlig{$aft})){ $lig = 0; } # $lig=0 + } + if ( $value =~ /->;.*;\+;/ ) { #;Reca_g(g~pY);+;SyktSH2_l(tSH2);<-> + if ( ($rlig{$aft} > 0)&&($lig==0) ) { # 2 + $lig = 1; # dalee $K(s) + } else { #add #;Reca_g(g~pY);+;SyktSH2_l(tSH2);<-> + @re = split(/\:/,$aft); #Syk:tSH2 + $tei1 = $re[0].$re[1]; #SyktSH2 + @re = split(/;\+;/,$out); #;Reca_g(g~pY) !! SyktSH2_l(tSH2);< + $out = $re[0].";+;".$re[1]; #;$Reca_g(g~pY);+;SyktSH2_l(tSH2);<-> + } + --$rlig{$aft}; # 2-1=> 1 + if(!($rlig{$aft})){ $lig = 0; } # $lig=0 + } + } + } + } ##foreach %lis1h + $val = $out.$val; + } ##key %dpp_site + if (!$fl) { return(undef); } # is not ;S(site1... + push(@$li,$val); + if ($lig) { goto mlig; } +} +#r_mac-end + +#pre_obs1-begin +sub pre_obs1{ +my ($nm_site, $nm2_site, $param_prefix, $skf, $dpp_site, $lis1h) = @_; + my ($ii); + my (@lis1); + + $obserfile= ">macr_${param_prefix}.obser"; # $obserfile= ">macr_${param_prefix}.obser"; + open (WFILEobser, $obserfile) or die "Can't open $obserfile: $!\n"; + print WFILEobser "begin observables\n"; + + @lis1 = (); + &del_blank(\@obser1vable,\@lis1); #-into observ--delete blank e.t. + + print WFILErec " FULL set of observables (n/n pre_rules)\n"; + foreach (@lis1) { # print observables(tests) + print WFILErec " $_ "; + print WFILErec "\n"; + } + &trans_obs($dpp_site,$lis1h,\@lis1,$skf); #---transform micro to macro(OBSERVABLES) + print WFILEobser "end observables\n"; + $ii=1; + foreach( @gene1rate ) { + if ( $_ =~ /^generate_network/) { $gener1 = $_; } + if ( $_ =~ /^simulate_ode/ ) { $simul1 = $_; $ii--; } + } + print WFILEobser "$gener1"; + +close(WFILEobser); + + # --------- SPECIES2------------- + + $spec2file= ">macr_${param_prefix}.spec2"; # $spec2file= ">macr_${param_prefix}.spec2"; + open (WFILEspec2, $spec2file) or die "Can't open $spec2file: $!\n"; + print WFILEspec2 "begin species\n"; # *.spec2 + + @lis1 = (); + &del_blank(\@species2,\@lis1); #-into species2--delete blank e.t. + + print WFILErec " FULL set of species2 (n/n pre_rules)\n"; + foreach (@lis1) { # print species2(tests) + print WFILErec " $_ "; + print WFILErec "\n"; + } + + &hash_skf(\@lis1,$skf,$nm2_site,"species2"); + &trans_specie($dpp_site,$lis1h,\@lis1); #---transform micro to macro(SPECIES) + print WFILEspec2 "end species\n"; # *.spec2 + + close(WFILEspec2); + +} +#pre_obs1-end + +#obs_mac0-begin +sub obs_mac0{ +my ($comp, $dpp_site, $lis1h, $skf) = @_; + my ($key, $key2, $key3, $out, $value, $no_complex, $lin_mac, $ii, $jj, $ij); + my (@rabm, @rab2, @re, @scaf, @rskf, @rabms); + my ($sit2, $rnam); + # %skf S:A site2 + $lin_mac = ""; + @scaf = split(/\./,$comp); # S A from S.A + for ($ii=0; $ii<=$#scaf; $ii++) { + for ($jj=0; $jj<=$#scaf; $jj++) { + if ((!$#scaf)||($scaf[0] eq $scaf[1])) { # one scaf Syk or Rec.Rec + @rskf=(); # no sites link + } else { + $ij = $scaf[$ii].":".$scaf[$jj]; # S:A A:S A:A + if ( !(defined($$skf{$ij})) ) { next; } + @rskf = @{$skf->{$ij}}; # S:A site2 + } + @rabm=(); + @rab2=(); + $no_complex = 0; + $key = $scaf[$ii]; #S + $out = $key; #S + keys %{$dpp_site}; # begin hash + while (($key2,$value) = each (%{$dpp_site})) { #S:site4 site1 site3 site4 + ($key3,undef) = split(/\:/,$key2); # S + if ( $key eq $key3 ) { # S S + @rab2 = sort @{$value}; # site1 site3 site4 + if (!(@rabm)){ # + @rabm = @rab2 # site1 site3 site4 rabm=activnye_sites is not + }; + @rabms = (); + foreach ( @rab2) { push(@rabms,$key3.":".$_); } # @rabms=S:site1 S:site3 S:site4 + + if ( !(@rskf) ) { # site1 site2 + if (&inc_set(\@rabm,\@rab2)) { # rab2=site1 site3 site4 include rabm=? + foreach(@rab2) { # rab2=site1 site3 site4 + $out .= $_."_"; # if(!($_ eq $rnam)) { $out ...= "_".$_; } # Ssite1_site3_site4 + } + chop($out); # $out .=join("_",@rab2); #Reca_b !! + ++$no_complex; + last; + } + } + if ( &inc_set(\@rskf,\@rabm) ) { # site2 include site1 site3 site4%skf S:A site2 + if (&inc_set(\@rabm,\@rab2)) { # rab2=456 include rabm=1234 ? + foreach(@rab2) { + $out .= $_."_"; #if(!($_ eq $rnam)) { $out .= "_".$_; } #;SyktSH2_a + } + chop($out); # $out .=join("_",@rab2); #Reca_b !! + ++$no_complex; + last; + } + } else { + @rabm = (); + } ##if site2 + } ##if $key eq $key3 + } ##while + if ($no_complex) { # there is no_complex R@rab2 + $lin_mac .= $out; #Reca_b Ssite1_site3_site4 OLD R1_2(1,0). + } else { # it is complex R.K + if ($#scaf) { + if ($lin_mac) { + $lin_mac .= ".".$key; #Ssite1_site3_site4.A OLD R1_2(1,0). + } else { + $lin_mac .= $key; #Ssite1_site3_site4 OLD R1_2(1,0). + } + } else{ + $lin_mac .= $key; #Lyn OLD R1_2(1,0). + } + } ##else + if ( $scaf[0] eq $scaf[1] ) { + return($lin_mac.".".$lin_mac); # Rec.Rec + } + } ## for jj OLD foreach @scaf + } ## for ii OLD foreach @scaf + return($lin_mac); +} +#obs_mac0-end + +#obs_mac-begin +sub obs_mac{ +my ($comp, $dpp_site, $lis1h, $mol, $mol_form, $skf) = @_; + my ($key, $key2, $key3, $out, $zout, $value, $jj, $ii,$nrabm,$rscaf,$i1); + my ($no_form, $lform, $hform, $zform, $mac, $sit,$no_dep); + my (@rabm, @irabm, @rab2, @re, @scaf, @rabms, @pere, @obed); + my ($sit2, $rnam); + my (%dep_del); #Molecules RecLig Lig(l1!1,l2).Rec(a1!1,b~y,g~Y) + @scaf = split(/\./,$comp); #Lig(l1!1,l2).Rec(a1!1,b~y,g~Y) + foreach (@scaf) { $rscaf = $_; #Lig(l1!1,l2) + if (!($_ =~ /\(/)) { $$mol .= &obs_mac0($_, $dpp_site, $lis1h, $skf)."."; next; } + @rabm=(); + @rab2=(); + keys %{$dpp_site}; # begin hash + ($key,$mac) = split(/\(/,$_); #Lig l1!1,l2); Rec a!1,b~Y,g~Y) + $mac =~ /\)/; #l1!1,l2); a!1,b~Y,g~Y) + $sit = $`; #l1!1,l2; a!1,b~Y,g~Y + @re = split(/\,/,$`); #l1!1 l2; a!1 b~Y g~Y + $jj=0; + @rabm = @re; #l1!1 l2; a!1 b~Y g~Y + foreach(@rabm) { $_ =~ s/[~!].*//;} #l1 l2; a b g + $out = $key; #Lig; Rec + $no_dep = 1; #Lig is not into dep; Rec is dep + $no_form = 0; @pere = (); + while (($key2,$value) = each (%{$dpp_site})) { #Rec:b a b + ($key3,undef) = split(/\:/,$key2); # Rec + if ($key eq $key3) { # Lig Rec else while; Rec Rec + @rab2 = sort @{$value}; # a b + $no_dep = 0; # Rec is into dep + @rabms = (); + + foreach ( @rab2) { push(@rabms,$key3.":".$_); } # @rabms=Rec:a Rec:b + if (&inc_set(\@rabm,\@rab2)) { # rab2=a b include @rabm a b g + foreach(@rab2) { + $out .= $_."_"; # if(!($_ eq $rnam)) { $out ...= "_".$_; } #;SyktSH2_a + } + chop($out); # Reca_b + ++$no_form; # it is not formala + last; # out from dpp_site + } else { + if (@pere) { &spere(\@pere,\@obed,\@rab2); } else {@pere = @rab2; @obed=@rab2;} + } + } ## if key eq key3 + } ##while dpp_site + if ($no_dep) { # Lig(l1!1,l2) is not dep + $out .= '('; # Lig( + $out .= $sit; # Lig(l1!1,l2 + $out .= ').'; # Lig(l1!1,l2). + $$mol .= $out; # Lig(l1!1,l2). + } else { # Rec there is dep + if ($no_form) { # there is no_form R@rab2 + $out .= '('; + foreach(@re){ $out .= $_.','; } # Rec(a!1, + chop($out); + $out .= ').'; # Rec(a!1). + $$mol .= $out; # + } else { $hform = ''; $zform = ''; $lform = ''; $nrabm = @rabm; # it is formulae + for ($ii=0;$ii<$nrabm;$ii++){$irabm[$ii]=0;} $ii =0; $i1=0; %dep_del =(); + while(!($i1)) { if ($ii > 2*$nrabm) { print WFILErec "INVALID GROUP OBSERVABLES $rscaf sites=@rabm"; last; } + &h_dep($dpp_site, \%dep_del, \@rabm, \@rab2, $out); #@rab2= a b ---prepare @rab2 + $out .=join("_",@rab2)."("; # Reca_b(; Reca_g( + foreach(@rab2){ # a b; a g + if ($jj = &inc_elt($_,\@rabm)) { # rabm = a b g; rabm = a b g + $irabm[$jj-1] = 1; # irabm = 1 1 0; irabm = 2 1 1 + $out .= $re[$jj-1].','; # Reca_b(a!1,b~Y,; Reca_g(a!1,g~Y, + } else { + $out .= "*,"; # Reca_b(*, + } + } + chop($out); # Reca_b(a!1,b~Y Reca_g(a!1,g~Y + $out .= ")"; # Reca_b(a!1,b~Y) Reca_g(a!1,g~Y) + if ($$mol) {$hform .= $$mol.$out."&"; # Lig(l1!1,l2).Reca_b(a!1,b~Y)& Reca_g(a!1,g~Y) + } else {$hform .= $out."&";} # Reca_b(a!1,b~Y)& Reca_g(a!1,g~Y) + $i1=1; for (@irabm) { $i1*=$_; } + $out = $key; # Rec + if ( $ii > 0 ) { + $zout = $out; # Rec + $zout .=join("_",@rab2)."("; # Reca_g( znamenatel' + foreach(@pere){ # a; + if ($jj = &inc_elt($_,\@rabm)) { # rabm = a b g; rabm = a b g + $zout .= $re[$jj-1].","; # Reca_b(a!1,; Reca_g(a!1,g~Y, + } + }##foreach + chop($zout); # Reca_g or Reca_b(a!1) + if (@pere) {$zout .= ")"; } + if ($$mol) {$zform .= $$mol.$zout."&"; # Lig(l1!1,l2).Reca_b(a!1,b~Y)& Reca_g(a!1,g~Y) + } else {$zform .= $zout."&";} # Reca_g(a!1)& + } ## $ii > 0 + $ii++; + } ##while rabm (activ sites) + chop($hform); chop($zform); + $lform .="[".$hform."]/[".$zform."]."; + $$mol = ""; + } ##else no_form + } ##if no_dep + } ## foreach @scaf + if ($lform) { $$mol_form .= $lform."#"; } + if ($$mol) { chop($$mol); } + return; +} +#obs_mac-end + +#trans_specie-begin +sub trans_specie{ #---transform micro to macro(SPECIES) +my ($dpp_site, $lis1h, $lis1) = @_; + my ($key, $skey, $rr, $key_dep, $key_obs, $value, $lin_mac, $key_d, $rak, $ind); + my ($stt, $sit, $is_dep, $sit2, $rnam); + my (@re, @ra, @ram, @rabms); + my (%spp, %rah); + + foreach (@{$lis1}) { # line from species ONE RR-MOLECULES + %rah=(); + %spp=(); + @ra=(); + @ram=(); + $is_dep = 0; + $stt = $_; #;Syk(tSH2,l~Y,a~Y);Syk_tot ;K(s);K_tot + (undef,@re) =split(/\;/,$stt); #Syk(tSH2,l~Y,a~Y) Syk_tot #OLD Rr(1,0,1,0) 386 or Recstart + $rr=$re[0]; #Syk(tSH2,l~Y,a~Y) S(site1,site2~Y,site3~Y,site4~Y) OLD Rr(1,0,1,0)=> $rr + if( !($rr =~ /\(/ )) { # search ( + $stt =~ s/;/ /g; ## not ( ; to blank + print WFILErec "$stt\n"; + print WFILEspec2 "$stt\n"; ### S S_tot + next; + } else { # it is ( + $rr =~ /\(/; #Syk(tSH2,l~Y,a~Y) S(site1,site2~Y,site3~Y,site4~Y) OLD 1,0,1,0) + $key_obs = $`; #Syk S OLD Rr + $sit = $'; #tSH2,l~Y,a~Y) + foreach $key_dep ( keys %{$dpp_site}) { #Rec:b + $skey=""; + $value = $dpp_site->{$key_dep}; #a b site1 site3 site4 + ($key_d,undef) = split(/\:/,$key_dep); #Rec:b S:site4 S=>$key_d OLD R=>$key_d + if ( $key_obs eq $key_d) { #Syk Rec S S + @ra = split(/\,/,$sit); #tSH2,l~Y,a~Y) site1,site2~Y,site3~Y,site4~Y) OLD @(1 0 1 0)) + chop($ra[$#ra]); #tSH2 l~Y a~Y site1 site2~Y site3~Y site4~Y OLD @(1 0 1 0) + @ram = @ra; #@ram=tSH2 l~Y a~Y site1 site2~Y site3~Y site4~Y OLD @(1 0 1 0) + foreach (@ra) { s/[!~].*//; } #@ra=tSH2 l a site1 site2 site3 site4 + $rak = ""; + @rabms = (); + foreach ( @{$value}) { push(@rabms,$key_d.":".$_); } # @rabms=Syk:a Syk:tSH2 + $skey = ''; # old=>$skey = $rnam; + foreach(sort @{$value}) { + $skey .=$_."_"; # if(!($_ eq $rnam)) { $skey .=$_."_"; } # a tSH2 + } + foreach (sort @{$value}){ # $skey .= $_."_"; # key =a_tSH2_ site1_site3_site4_ OLD 1_1_0_ + $ind = &inc_elt($_,\@ra)-1; + $rak .= $ram[$ind].','; # rak =tSH2,a~Y, site1,site3,site4, OLD 1,1,0, + } + $skey = $key_obs.$skey; # skey=Syka_tSH2 Ssite1_site3_site4_ OLD 1_1_0_Rr + chop($rak); # rak =tSH2,a~Y site1,site3~Y,site4~Y OLD 1,1,0 + chop($skey); # skey=Syka_tSH2 Ssite1_site3_site4 + $rah{$skey} = $rak; # %rah{Syka_tSH2}=tSH2,a~Y Syk(Ssite1_site3_site4 site1,site3~Y,site4~Y) OLD (1_1_0_Rr 1,1,0) + if ($re[1] =~ /^\D/){ # Syk_tot S_tot or 386 + $spp{$skey} += $para1ms{$re[1]}; # summa start_species + } else { + $spp{$skey} +=$re[1]; # summa start_species + } + $is_dep = 1; + #Syk = Syk K(s) K_tot + } ##if + } ##key_dep + if ( $is_dep ) { + foreach $key ( keys %spp ){ # key=Syka_tSH2 Ssite1_site3_site4 OLD 1_1_0_Rr + $lin_mac = $key; # Syka_tSH2 S OLD Rr + $lin_mac .= '('; # Syka_tSH2( Ssite1_site3_site4( OLD Rr1_3_4( + $lin_mac .= $rah{$key}.');'; # Syka_tSH2(tSH2,a~Y); Ssite1_site3_site4(site1,site3~Y,site4~Y) OLD Rr1_3_4(1,1,0); + $lin_mac .= $spp{$key}; # Syka_tSH2(tSH2,a~Y);summa + $lin_mac =~ s/;/ /g; # ; to blank + print WFILErec $lin_mac; # Rr1_3_4(1,1,0) Rec_start + print WFILErec "\n"; + print WFILEspec2 $lin_mac; # Rr1_3_4(1,1,0) Rec_start + print WFILEspec2 "\n"; + } ##key + } else { # it is not into dep + $stt =~ s/;/ /g; # Lig(l,l) L_tot + print WFILErec "$stt\n"; + print WFILEspec2 "$stt\n"; ### Lig(l,l) L_tot S S_tot + next; + } + } #else it is ( + $is_dep = 0; + } #lis1 +} +#trans_specie-end + +#get_line-begin +sub get_line{ + my $line=""; + while($line= shift(@$file_dat)){ + ++$line_number; + chomp($line); + $line=~ s/\#.*$//; # remove comments + next unless $line=~/\S+/; # skip blank lines + while ($line=~ s/\\\s*$//){ + ++$line_number; + my $nline= shift(@$file_dat); + chomp($nline); + $nline=~ s/\#.*$//; # remove comments + $line.= $nline; + next unless (!@$file_dat); + } + last; + } + return($line); +} +#get_line-end + +#read_block_array-begin +sub read_block_array{ + my $name= shift; + my @array=(); + + my $got_end=0; + while($_=get_line()){ + # Look for end of block or errors + if (s/^\s*end\s+//){ + my $ename= $_; + $ename=~ s/\s*$//; + $ename=~ s/\s+/ /g; + if ($ename ne $name){ + return([],errgen("end $ename does not match begin $name")); + } else { + $got_end=1; + #print "end at $line_number\n"; + last; + } + } + elsif (/^\s*begin\s*/){ + return([],errgen("begin block before end of previous block $name")); + } + # Add declarations from current line + push @array, [($_, $line_number)]; + #print "$_ $line_number\n"; + } + + if (!$got_end){ + return([],errgen("begin $name has no matching end $name")); + } + + return([@array]); +} +#read_block_array-end + +#errgen-begin +sub errgen{ + my $err= shift; + my $lno= (@_) ? shift : $line_number; + $err=~ s/[*]/\*/g; + my $reterr= sprintf "%s\n at line $lno of file $file", $err; + return($reterr); +} +#errgen-end + +#version-begin (substituted) +sub version{ +return $base_model->version(); +} +#version-end (substituted) + +#L_AiAn_BiBn-begin +sub L_AiAn_BiBn{ # (\%croc,\%ms,\@rabn,\@rabi,\@reac,\$n_adds,\%dubl); +my ($croc,$ms,$rabn,$rabi,$reac,$n_adds,$dubl) = @_; +my ($nnn,$nni,$s3n,$s3i,$an,$bn,$ai,$bi,$nkn,$nki,$ln); +my (@rabm); + ($nnn,$an,$bn,$s3n,$nkn) = @$rabn; + ($nni,$ai,$bi,$s3i,$nki) = @$rabi; + $tnnn = $nnn; + $tnni = $nni; +if ( $nkn eq $nki ) { + if ( $bi==$bn && !(exists($$dubl{$bi})) && cros($croc,$ms,$ai,$an) ) { + &add_ts3n($an, $bn); # add s3n into @$ts3n{$bn} + $ln = $an.",".$bn." ".$s3n.",".$bn." ".$nkn; + $$reac[$nnn-1] = sprintf "%5d %s\n", $nnn, $ln; + $$rabn[3] = $s3n.",".$bn; + $$n_adds++; $$dubl{$bi} = 1; + } + if ( $bi==$an && !(exists($$dubl{$bi})) && cros($croc,$ms,$ai,$bn) ) { + &add_ts3n($an, $bn); # add s3n into @$ts3n{$bn} + $ln = $an.",".$bn." ".$s3n.",".$an." ".$nkn; + $$reac[$nnn-1] = sprintf "%5d %s\n", $nnn, $ln; + $$rabn[3] = $s3n.",".$an; + $$n_adds++; $$dubl{$bi} = 1; + } + if ( $ai==$an && !(exists($$dubl{$ai})) && cros($croc,$ms,$bi,$bn) ) { + &add_ts3n($an, $bn); # add s3n into @$ts3n{$bn} + $ln = $an.",".$bn." ".$s3n.",".$an." ".$nkn; + $$reac[$nnn-1] = sprintf "%5d %s\n", $nnn, $ln; + $$rabn[3] = $s3n.",".$an; + $$n_adds++; $$dubl{$ai} = 1; + } + if ( $ai==$bn && !(exists($$dubl{$ai})) && cros($croc,$ms,$bi,$an) ) { + &add_ts3n($an, $bn); # add s3n into @$ts3n{$bn} + push(@ts3n,$s3n); + $ln = $an.",".$bn." ".$s3n.",".$bn." ".$nkn; + $$reac[$nnn-1] = sprintf "%5d %s\n", $nnn, $ln; + $$rabn[3] = $s3n.",".$bn; + $$n_adds++; $$dubl{$ai} = 1; + } +} ##if nkn +} +#L_AiAn_BiBn-end + +#cros-begin +sub cros{ # cros(\%croc,\%ms,$ai,$an) +my ($croc,$ms,$ai,$an) = @_; +my ($li1,$li2,$na1,$na2,$teil1,$teil2,$ii,$jj,$tei1out,$tei2out); +my (@rr1,@rr1out,@sit1,@rr2,@rr2out,@sit2,@rr2mac,@am,@bm,@aonly,@par1,@par2); +my (%rr1mac,%rr2mac,%seen); + +STEP1: + @par1 = (); @par2 = (); + + @rr1 = (); %rr1mac = (); + $li1 = $species[$ai-1]; #Sykl_tSH2(l~Y,tSH2) + @rr1 = split(/\./,$li1); # NABOR [Lig Sykl_tSH2(l~Y,tSH2)] micro and macro belkov species1 + foreach (@rr1) { + $_ =~ /\(/; # NABOR [Sykl_tSH2 Reca_b] macro-name into @rr1mac + if ( exists($$ms{$`}) ) { $rr1mac{$_} = $`; } #Syka_tSH2(a~Y,tSH2)] Syka_tSH2 + } + + @rr2 = (); %rr2mac = (); + $li2 = $species[$an-1]; #Syka_tSH2(a~Y,tSH2) + @rr2 = split(/\./,$li2); # NABOR [Lig Sykl_tSH2(l~Y,tSH2)] micro and macro belkov species2 + foreach (@rr2) { + $_ =~ /\(/; # NABOR [Syka_tSH2 Reca_g] macro-name into @rr2mac + if ( exists($$ms{$`}) ) { $rr2mac{$_} = $`; } #Sykl_tSH2(l~Y,tSH2)] Sykl_tSH2 + } + + while ( ($teil1,$na1) = each(%rr1mac) ) { # pary (Q1 Q2) (R1 R2)... + while ( ($teil2,$na2) = each(%rr2mac) ) { + if ( $na1 ne $na2 && $$ms{$na1} eq $$ms{$na2} ) { + push(@par1,$teil1); push(@par2,$teil2); + } + } + } +STEP2x3: +# if ( !(defined(@par1)) ) { + if ( !(@par1) ) { + return(0); # It's not odnorodny + } else { # It's odnorodny + for ( $jj=0; $jj<=$#par1; $jj++) { # pary macro-name (Q1 Q2) (R1 R2)... + $teil1 = $par1[$jj]; $teil2 = $par2[$jj]; # pary macro-name (Q1 Q2) (R1 R2)... + @rr1out = (); @rr2out = (); + $na1 = $rr1mac{$teil1}; # Syka_tSH2 + $na2 = $rr2mac{$teil2}; # Sykl_tSH2 + @am = @{$$croc{$na1}}; # a b + @bm = @{$$croc{$na2}}; # a g + &del_set(\@am,\@bm,\@aonly); +## %seen = (); # search elements from $am which not into @bm +## @seen{@am} = (); # creat tabl view dependence sites +## delete @seen{@bm}; # +## @aonly = keys %seen; # only keys (am - bm) = neobshie sites(ab - ag => b) + delsites(\@rr1,$teil1,\@aonly,\@rr1out,\$tei1out); + $tei1out =~ s/$na1//; + + @am = @{$$croc{$na1}}; + @bm = @{$$croc{$na2}}; + &del_set(\@bm,\@am,\@aonly); +## %seen = (); # search elements from $bm which not into @am +## @seen{@bm} = (); # creat tabl view dependence sites +## delete @seen{@am}; # +## @aonly = keys %seen; # only keys (bm - am) = neobshie sites(ag - ab => g) + delsites(\@rr2,$teil2,\@aonly,\@rr2out,\$tei2out); + $tei2out =~ s/$na2//; + if ( $tei1out eq $tei2out ) { + print WFILErec "Hom_spes: reac=$tnni,$tnnn spes=$ai,$an $teil1 <=> $teil2\n"; + return(1); + } # It's odnorodny + } ##for $jj pary + return(0); + } ##if step2 +} +#cros-end + +#delsites-begin +sub delsites{ # delsites(\@rr1,$teil1,\@aonly,\@rr1out,\tei1out); +my ($rr1,$teil1,$aonly,$rr1out,$tei1out) = @_; #nabor_belkov Reca_b(a,b~Y) b +my ($ii,$jj,$me,$tei,$sit,$ind0,$ind1,$ind2,$ou1); +my (@met,@rr1sor,@si,@sisor,@keyrr1s); +my (%rr1s); + + @$rr1out = (); push(@$rr1out,@$rr1); + for ($ii=0; $ii<=$#$aonly; $ii++) { # b-site + @met = (); + $sit = $$aonly[$ii]; # g + $tei = $teil1; #Reca_g(g~pY!3,a!1,t~..) or Reca_g(a!1,g~pY!3,t~..) + $tei =~ /\($sit|\,$sit/; # (g or ,g + $ind0 = $`; #Reca_g(a!1 or Reca_g + $ind1 = $&; # (g or ,g + $ind2 = $'; # ~pY!3,t~..) or ~Y,.. or ,t~.. or !3,t~. or !3) + $ind2 =~ /\,|\)/; #$`= ~pY!3 or ~Y or'' or !3 or !3 + #$'= t~..) or t~..) or t~..) or'' + if ( "(".$sit eq $ind1 ) { + $tei = $ind0."(".$'; + if ( $`) { + (undef,@met) = split(/!/,$`); #~pY 3 metki 3 i t.d. + } #~pY 3 metki 3 i t.d. + } else { + if ( $`) { + (undef,@met) = split(/!/,$`); + } + if ( $') { $tei = $ind0.",".$'; } else { $tei = $ind0.")"; } + } + $jj = 0; + while ( $$rr1out[$jj] ne $teil1) { $jj++; } # found teil1 + $$rr1out[$jj] = $tei; # + $teil1 = $tei; # + + while ( $#met >= 0 ) { # psevdo_recurs + $me = pop(@met); # 4 + for ($jj=0; $jj<=$#$rr1out; $jj++) { + $tei = $$rr1out[$jj]; #Lig(l!1,l!4) + if ( $tei =~ /!$me/ ) { # found !4 + selectmet(\@met,$tei,$me); # + $$rr1out[$jj] = undef; + last; ## jj + } ##if + } ## for $jj + } ## while @met + } ##for $ii b-sites + + for ($jj=0; $jj<=$#$rr1out; $jj++) { + $ind0 = $$rr1out[$jj]; + $ind0 =~ s/!.+?[\,\)]/#,/g; # !x12!5, or !x12!5)=> #, + $rr1s{$ind0} = $jj; + } + @keyrr1s = sort (keys %rr1s); # SORTING keys %rr1s= Syka_tSH2(a~Y,tSH2#, + foreach $jj (@keyrr1s) { + push(@rr1sor,$$rr1out[$rr1s{$jj}]); # SORTING belkov + } + @$rr1out = (); $ou1 = ''; + foreach $jj (@rr1sor) { + if ( $jj) { #Syka_tSH2(a~Y,tSH2!3) + ($ind0,$ind1) = split(/\(/,$jj); #Syka_tSH2 a~Y,tSH2!3) + chop($ind1); # a~Y,tSH2!3 + @si = split(/,/,$ind1); # a~Y tSH2!3 + @sisor = sort @si; # SORTING sites + $ind2 = $ind0."(".join(",",@sisor).")"; #Syka_tSH2(a~Y,tSH2!3) + $ou1 .= $ind2."."; #Reca_g(a!1,g~pY!3).Sykl_tSH2(l~Y,tSH2!3) + push(@$rr1out, $ind2 ); + } ##if jj + } ## foreach jj + chop($ou1); + $jj = 0; + while ( $ou1 =~ /!/ ) { + $jj++; + $ou1 =~ /!.+?[\,\)\!]/; #$&= !xx.., or !xx..) or !xx..! + $ind2 = $&; + chop($ind2); + $ou1 =~ s/(?:$ind2)/#$jj/g; + } + $$tei1out = $ou1; +} +#delsites-end + +#add_ts3n-begin +sub add_ts3n{ # add_s3n($an,$bn); +my ($an, $bn) = @_; # add an.bn into %ts3n + if ( !(exists($ts3n{"$an.$bn"})) ) { + $ts3n{"$an.$bn"} = 1; + } +} +#add_ts3n-end + +#R_AiAn_BiBn-begin +sub R_AiAn_BiBn{ #(\%croc,\%ms,\@rabn,\@rabi,\@reac,\$n_subtracts,\%dubl); +my ($croc,$ms,$rabn,$rabi,$reac,$n_adds,$dubl) = @_; +my ($nnn,$nni,$s1n,$s1i,$an,$bn,$ai,$bi,$nkn,$nki,$ln); + ($nnn,$s1n,$an,$bn,$nkn) = @$rabn; + ($nni,$s1i,$ai,$bi,$nki) = @$rabi; + $tnnn = $nnn; + $tnni = $nni; +if ( $nkn eq $nki ) { + if ( $bi==$bn && !(exists($$dubl{$bi})) && cros($croc,$ms,$ai,$an) ) { + $ln = $s1n." ".$an." ".$nkn; + $$reac[$nnn-1] = sprintf "%5d %s\n", $nnn, $ln; + $$n_adds++; $$dubl{$bi} = 1; + } + if ( $bi==$an && !(exists($$dubl{$bi})) && cros($croc,$ms,$ai,$bn) ) { + $ln = $s1n." ".$bn." ".$nkn; + $$reac[$nnn-1] = sprintf "%5d %s\n", $nnn, $ln; + $$n_adds++; $$dubl{$bi} = 1; + } + if ( $ai==$an && !(exists($$dubl{$ai})) && cros($croc,$ms,$bi,$bn) ) { + $ln = $s1n." ".$bn." ".$nkn; + $$reac[$nnn-1] = sprintf "%5d %s\n", $nnn, $ln; + $$n_adds++; $$dubl{$ai} = 1; + } + if ( $ai==$bn && !(exists($$dubl{$ai})) && cros($croc,$ms,$bi,$an) ) { + $ln = $s1n." ".$an." ".$nkn; + $$reac[$nnn-1] = sprintf "%5d %s\n", $nnn, $ln; + $$n_adds++; $$dubl{$ai} = 1; + } +} ##if nkn +} +#R_AiAn_BiBn-end + +#selectmet-begin +sub selectmet { # selectmet(\@met,$tei,$me); +my ($met,$tei,$me) = @_; +my ($te,$te1,$ii,$ch1,$ch2); +my (@rr,@mm); + @rr = split(/,/,$tei); #Reca_g(a!1 g~pY!3) + ($ch1,$ch2) = split(/!/,$rr[0]); #Reca_g(a 1 or ..(...3) + if ($ch2) { + if ( $ch2 =~ /\)$/ ) { chop($ch2); } + if ( $ch2 ne $me) { push( @{$met}, $ch2); } + $ch1 =~ s/\(.//; #Reca_g + $ch1 .= "("; #Reca_g( + } + $te1 = $ch1; #Reca_g(a..) or Reca_g( + + for ($ii=1; $ii<=$#rr; $ii++) { + $te = $rr[$ii]; #g~pY!3) or g~py!2 + ($ch1,$ch2) = split(/!/,$te); #g~pY 3) or g~py 2 + if ($ch2) { + $ch2 =~ s/\)$//; # 3 + if ( $ch2 ne $me) { push( @{$met}, $ch2); } + } + } ##for $ii +} +#selectmet-end + +#h_dep-begin +sub h_dep{ # @rabm = a b g $out=Rec +my ($dpp_site, $dep_del, $rabm, $rab2, $out) = @_; # @rab2 - output + my ($n_in, $key2, $key, $key_mi, $value, $jj); + my (@ind_var, @act_sites); + + $key_mi = ""; # @rabm = a b g; a b g + @$rab2 = (); # %dep_v=(); + + while (($key,$value) = each (%{$dpp_site})) { # Rec:b a b; Rec:g a g + if ( !($$dep_del{"0".$key}) ) { + ($key2,undef)= split(/\:/,$key); # Rec + if ($out eq $key2) { # Rec Rec + @ind_var = @{$value}; # a b; a g + $n_in = 0; + $jj = 0; + foreach (@{$rabm}){ # a b g + if (&inc_elt($$rabm[$jj],\@ind_var)) { # a,b,g a b; a,b,g a g + ++$n_in; # 2; 1 + } + ++$jj; + }##for # nige minimizaciy argymentov + if ($n_in) { # @{$dep_v{$key_mi}} = @ind_var; # (Krist p197 and + if (@$rab2) { if ( $#{$rab2} > $#ind_var) {@$rab2 = @ind_var; $key_mi = $key; } + } else { @$rab2 = @ind_var; $key_mi = $key; } # a b; a g + } + } ##if out eq key2 + } ##ifdep_del + } ##while dpp_site + $$dep_del{"0".$key_mi}=1; + +return; +} +#h_dep-end + +######################### +######################### + +} + +1; +########################################################################################################################## diff --git a/libvcell/vcell_install/bionetgen/Perl2/Map.pm b/libvcell/vcell_install/bionetgen/Perl2/Map.pm new file mode 100644 index 0000000..259db0e --- /dev/null +++ b/libvcell/vcell_install/bionetgen/Perl2/Map.pm @@ -0,0 +1,371 @@ +package Map; + +# pragmas +#use strict; +#use warnings; +no warnings 'redefine'; + +# Perl Modules +use Class::Struct; +use FindBin; +use lib $FindBin::Bin; + +# BNG Modules +use BNGUtils; +use SpeciesGraph; + + + +# A Map object manages forward and reverse mappings from a source SpeciesGraph +# into a target SpeciesGraph. The mapping is maintained as a hash map with +# source 'pointer' keys and target 'pointer' values. +# Pointer format: +# molecule pointer = "m" : where m is index of the molecule in the +# SpeciesGraph's Molecule array +# component pointer = "m.c" : where c is the index of the component in the +# Molecule's Component array. +struct Map => { + Source => 'SpeciesGraph', + Target => 'SpeciesGraph', + MapF => '%', # Forward mapping of Source onto Target + MapR => '%', # Reverse mapping of Target onto Source +}; + + +sub toString +# Map->toString() +# generates a string representation of Map. +# there is bijection from Maps to MapStrings. +# +# NOTE: this is for maps in the "mol.comp" style, not "patt.mol.comp" +{ + my $map = shift; + + my $string = ''; + my $molecules = $map->Source->Molecules; + + foreach my $im (0..$#{$molecules} ) + { + my $im2 = $map->MapF->{$im}; + $string .= sprintf " %d->%d(", $im+1, $im2+1; + next if ( $im2 < 0 ); + foreach my $ic ( 0..$#{$molecules->[$im]->Components} ) + { + my ($im2, $ic2) = split( '\.', $map->MapF->{"$im.$ic"} ); + $string .= sprintf " %d->%d", $ic+1, $ic2+1; + } + $string .= ')'; + } + return $string; +} + + + +### +### +### + + + +sub mapF +# p2 = Map->mapF(p1) +# returns the image of a pointer under map. +# +# p2 = Map->mapF(p1, offset) +# returns the image of a pointer under map, accounting for offset +# due to embedding of pattern within a species. +{ + my $map = shift; + my $p1 = shift; + my $offset = (@_) ? shift : 0; + + my $p2 = $map->MapF->{$p1}; + if ($offset) + { + my ($im2, $ic2) = split('\.', $p2); + $im2 += $offset; +# if ($ic2 ne '') + if (defined $ic2) + { $p2 = "$im2.$ic2"; } + else + { $p2 = "$im2"; } + } + + return $p2; +} + + + +### +### +### + + + +sub get_induced_permutation +# (autoP, err) = autoR->get_induced_permutation(map) +# +# autoR: R -> R +# map: R -> P +# permP: P -> P +# +# NOTE: this is a replacement for mapAuto. +# the new version is simplified, and creates a new Map object to contain +# autoP, rather than overwriting autoR. +# +# permP o map == map o autoR +# permP = map o autoR o map^-1 +# let R be the reactant objects (molecules and components) +# and P be the product objects. +# +# ... More details ... +# given maps: +# +# autoR: R -> R (automorphism of R) +# map: R* -> P (partial mapping of R into P) +# +# where R* is the subset of R for which map is defined +# (members of R which are deleted in a rxn will not be in R*), +# and P* is the image of map(R*), +# +# then find a permuation of P, permP: P -> P, such that for all r in R* +# +# permP o map == map o autoR ( "o" is the composition operator ) +# +# +# R ----autoR--> R' +# | | +# map map +# | | +# v v +# P ----candP---> P' +# +# permP is a candidate automorphism of P. +{ + my $autoR = shift; + my $map = shift; + + if ($autoR->Source != $autoR->Target) + { return undef, "Map::get_induced_permutation() called from a non-self map"; } + + if ($autoR->Source != $map->Source) + { return undef, "Map::get_induced_permuation(): autoR and map have different source patterns"; } + + # create map object to hold P-permutation + my $permP = new Map; + my $mapF = {}; + $permP->Source( $map->Target ); + $permP->Target( $map->Target ); + $permP->MapF( $mapF ); + + # loop over nodes in P + foreach my $Pnode ( keys %{$map->MapR} ) + { + # get the inverse of P under the rule map + my $inv_Pnode = $map->MapR->{$Pnode}; + if ( $inv_Pnode < 0 ) + { # Pnode is created by rule (not in the image of R) + # use identity mapping + $mapF->{$Pnode} = $Pnode; + } + else + { # Pnode is in the image of R + # calculate: map o autoR o map^-1 (Pnode) + $mapF->{$Pnode} = $map->MapF->{ $autoR->MapF->{$inv_Pnode} }; + } + } + + return $permP, ''; +} + + + + +## Transform self-map according to map given as argument +## --Jim +## +## NOTE: This routine is deprecated, use "get_induced_permutation" instead. + +#sub mapAuto +## err = autoR->mapAuto(map) +## +## autoR: R -> R +## map: R* -> P +## +## note: candP is constructed on top of autoR +#{ +# my $autoR = shift; +# my $map = shift; +# +# if ($autoR->Source != $autoR->Target) +# { return "mapAuto called on non-self map"; } +# +# if ($autoR->Source != $map->Source) +# { return "mapAuto: Argument map not compatible with autoR" ; } + +# # Change map Source and Target +# $autoR->Source($map->Target); +# $autoR->Target($map->Target); + +# # Set up identity map +# # (this handles molecules in Target that are not in the Source) +# my $candP = {}; +# my $molecules = $map->Target->Molecules; +# foreach my $im ( 0..$#{$molecules} ) +# { +# $candP->{$im} = "$im"; +# foreach my $ic ( 0..$#{$molecules->[$im]->Components} ) +# { $candP->{"$im.$ic"} = "$im.$ic"; } +# } +# +# # Transform self-map +# foreach my $src_element ( keys %{$autoR->MapF} ) +# { +# my $perm_src_element = $autoR->MapF->{$src_element}; +# my $targ_element = $map->MapF->{$src_element}; +# my $perm_targ_element = $map->MapF->{$perm_src_element}; +# next if ( $targ_element < 0 ); +# $candP->{$targ_element} = $perm_targ_element; +# } + +# # Replace MapF (NOTE: MapR is not changed! This is because it should not be +# # used by self-map, which is generated by calling subGraphIsomorphism)) +# $autoR->MapF( $candP ); +# return ''; +#} + + +### +### +### + + +# transfer Labels and Attributes on source graph to the target graph +sub transferLabels +{ + my $map = shift; + + my $source = $map->Source; + my $target = $map->Target; + + # transfer speciesGraph label and attributes + $target->Label( $source->Label ) if (defined $source->Label); + $target->MatchOnce( $source->MatchOnce ) if (defined $source->MatchOnce); + $target->Fixed( $source->Fixed ) if (defined $source->Fixed); + + # loop over molecules + for ( my $imol = 0; $imol < @{$source->Molecules}; ++$imol ) + { + my $mol = $source->Molecules->[$imol]; + # transfer molecule label + if (defined $mol->Label) + { + my $imol_targ = $map->MapF->{$imol}; + $target->Molecules->[$imol_targ]->Label( $mol->Label ); + } + + # loop over components + for ( my $icomp = 0; $icomp < @{$mol->Components}; ++$icomp ) + { + my $comp = $mol->Components->[$icomp]; + # transfer component label + if (defined $comp->Label) + { + my ($imol_targ, $icomp_targ) = split /\./, $map->MapF->{"$imol.$icomp"}; + $target->Molecules->[$imol_targ]->Components->[$icomp_targ]->Label( $comp->Label ); + } + } + } +} + + + +### +### +### + + +sub copy +{ + my $map = shift; + + my $map_copy = Map::new(); + $map_copy->Source( $map->Source ); + $map_copy->Target( $map->Target ); + %{ $map_copy->MapF } = %{ $map->MapF }; + %{ $map_copy->MapR } = %{ $map->MapR }; + + return $map_copy; +} + + +### +### +### + + +sub copy_map_and_target +{ + my $map = shift; + + my $target_copy = $map->Target->copy(); + + my $map_copy = Map::new(); + $map_copy->Source( $map->Source ); + $map_copy->Target( $target_copy ); + %{ $map_copy->MapF } = %{ $map->MapF }; + %{ $map_copy->MapR } = %{ $map->MapR }; + + return $map_copy; +} + + +### +### +### + + +sub copy_map_and_source +{ + my $map = shift; + + my $source_copy = $map->Source->copy(); + + my $map_copy = Map::new(); + $map_copy->Source( $source_copy ); + $map_copy->Target( $map->Target ); + %{ $map_copy->MapF } = %{ $map->MapF }; + %{ $map_copy->MapR } = %{ $map->MapR }; + + return $map_copy; +} + + +### +### +### + + +sub copy_map_source_and_target +{ + my $map = shift; + + my $target_copy = $map->Target->copy(); + my $source_copy = $map->Source->copy(); + + my $map_copy = Map::new(); + $map_copy->Source( $source_copy ); + $map_copy->Target( $target_copy ); + %{ $map_copy->MapF } = %{ $map->MapF }; + %{ $map_copy->MapR } = %{ $map->MapR }; + + return $map_copy; +} + + +### +### +### + + +1; diff --git a/libvcell/vcell_install/bionetgen/Perl2/ModelWrapper.pm b/libvcell/vcell_install/bionetgen/Perl2/ModelWrapper.pm new file mode 100644 index 0000000..c2609b7 --- /dev/null +++ b/libvcell/vcell_install/bionetgen/Perl2/ModelWrapper.pm @@ -0,0 +1,148 @@ +package ModelWrapper; + +use strict; +use warnings; + +# BNG Modules +use Class::Struct; +use FindBin; +use lib $FindBin::Bin; +use File::Spec; + +# Perl Modules +use BNGUtils; +use BNGModel; + + + + +# A class that wraps a model and implements user friendly +# actions for console users +struct ModelWrapper => +{ + Name => '$', + Model => 'BNGModel', + Defaults => '%', +}; + + +### +### +### + + +# load model spec from file +sub load +{ + my $modelwrapper = shift @_; + my $file = @_ ? shift @_ : undef; + + if ( defined $modelwrapper->Model ) + { + printf "MODEL.load(FILE): model %s is already defined.\n", $modelwrapper->Name; + return 0; + } + + unless ( $file ) + { + printf "MODEL.load(FILE): file argument is empty.\n"; + return 0; + } + + unless ( -e $file ) + { + print "MODEL.load(FILE): file %s cannot be found.\n", $file; + return 0; + } + + unless ( -r $file ) + { + print "MODEL.load(FILE): file %s is not readable.\n", $file; + return 0; + } + + # create BNGModel object + $modelwrapper->Model = BNGModel->new(); + # make local copy of params + my $local_params = { %{$modelwrapper->Defaults} }; + # add filename to params + $local_params->{file} = $file; + + # read and process Model file + my $err = $modelwrapper->Model->readFile( $local_params ); + if ($err) + { + print "MODEL.load(FILE): some problem parsing model file $file.\n"; + print "errmsg: $err\n"; + return 0; + } + + return 1; +} + +### +### +### + + +# clear model spec +sub clear +{ + my $modelwrapper = shift @_; + + %{$modelwrapper->Model} = (); + undef %{$modelwrapper->Model}; + $modelwrapper->Model(undef); + + return 1; +} + + +### +### +### + + +# get/set model state +sub state +{ + my $modelwrapper = shift @_; + + my $model = $modelwrapper->Model; + unless ( defined $model ) + { + printf "MODEL.load(FILE): model %s is not defined.\n", $modelwrapper->Name; + return 0; + } + + if (@_) + { + # set state + my $state = shift @_; + + unless ( @$state == $model->SpeciesList->getNumSpecies() ) + { + print "MODEL.state(STATE): length of STATE vector does not equal the number of species.\n"; + return 0; + } + + my $state_copy = [ @$state ]; + $model->Concentrations( $state_copy ); + return 1; + } + else + { + # get state + my $state_copy = []; + if ( @{$model->Concentrations} ) + { + @$state_copy = @{$model->Concentrations}; + } + else + { + @$state_copy = grep {$_->Concentration} @{$model->SpeciesList->Array}; + } + return 1, $state_copy; + } +} + diff --git a/libvcell/vcell_install/bionetgen/Perl2/Molecule.pm b/libvcell/vcell_install/bionetgen/Perl2/Molecule.pm new file mode 100644 index 0000000..e9e3418 --- /dev/null +++ b/libvcell/vcell_install/bionetgen/Perl2/Molecule.pm @@ -0,0 +1,773 @@ +# $Id: Molecule.pm,v 1.9 2007/07/06 04:48:21 faeder Exp $ + +package Molecule; + +# pragmas +use strict; +use warnings; + +# Perl Modules +use Class::Struct; +use FindBin; +use lib $FindBin::Bin; +use Storable qw(dclone); + + +# BNG Modules +use Component; +use BNGUtils; + +# constants +use constant { TRUE => 1, + FALSE => 0 + }; + + + +struct Molecule => +{ + Name => '$', + State => '$', + Edges => '@', + Label => '$', + Compartment => 'Compartment', + Components => '@', + Context => '$' +}; + + + +### +### +### + + + +sub newMolecule +{ + my $string = shift @_; + my $clist = shift @_; + + my $mol = Molecule->new(); + my $err = $mol->readString( $string, $clist ); + return ($mol, $err); +} + + + +### +### +### + + + +sub readString +{ + my $mol = shift; + my $strptr = shift; + my $clist = shift; + + my $string_left = $$strptr; + + # Get molecule name (cannot start with a number) + if ( $string_left =~ s/^([A-Za-z_]\w*)// ) + { + $mol->Name($1); + } + else + { + return undef, "Invalid Molecule name in '$string_left' (must begin with a letter or underscore)."; + } + + # Get molecule state (marked by ~) edges (marked by !) and label (marked by + # %) and components (enclosed in ()) + my $edge_wildcard = 0; + while ($string_left) + { + # Read components in parentheses + if ( $string_left =~ s/^[(]// ) + { + if (@{$mol->Components}) + { + return undef, "Multiple component definitions"; + } + while ($string_left) + { + # Continue characters + next if ( $string_left =~ s/^,// ); + # Stop characters + last if ( $string_left =~ s/^\)// ); + + # Read component + my ( $comp, $err ) = Component::newComponent( \$string_left ); + if ($err) { return undef, $err; } + + # Save components + push @{$mol->Components}, $comp; + } + } + + # Read attributes in braces + elsif ( $string_left =~ s/^[{]// ) + { + while ( !( $string_left =~ s/^\}// ) ) + { + my $attr = ''; + my $value = ''; + + # Get attribute name + if ( $string_left =~ s/^([^,=\}]+)// ) + { + $attr = $1; + } + else + { + return undef, "Null attribute for Molecule at $string_left"; + } + + # Get (optional) attribute value + if ( $string_left =~ s/^=([^,\}]+)// ) + { + $value = $1; + } + + # Remove trailing comma + $string_left =~ s/^,//; + + if ( $attr eq "Context" ) + { + my $val = booleanToInt($value); + if ( $val == -1 ) + { + return undef, "Invalid value $value assigned to Boolean attribute $attr"; + } + $mol->Context($val); + } + else + { + return undef, "Invalid attribute $attr for Molecule"; + } + } + } + + # Read state, edge, label, or compartment + elsif ( $string_left =~ s/^([~%!@])(\w+|\+|\?)// ) + { + my $type = $1; + my $arg = $2; + if ( $type eq '~' ) + { # State label + if ( defined $mol->State ) + { + return undef, "Multiple state definitions"; + } + if ( $arg =~ /(\w+|\?)/ ) { $mol->State($arg); } + else + { + return undef, "Invalid state label in molecule"; + } + } + elsif ( $type eq '!' ) + { # Bond label or wildcard + if ( $arg =~ /^[+?]$/ ) + { + if ($edge_wildcard) + { + return undef, "Multiple edge wildcards in molecule"; + } + $edge_wildcard = 1; + push @{$mol->Edges}, $arg; + } + } + elsif ( $type eq '%' ) + { # Tag label + if ( defined $mol->Label ) + { + return undef, "Multiple label definitions"; + } + $mol->Label($arg); + } + elsif ( $type eq '@' ) + { # Compartment label + if ( defined $mol->Compartment ) + { + return undef, "Multiple compartment definitions"; + } + + if ( my $comp = $clist->lookup($arg) ) + { + $mol->Compartment($comp); + } + else + { + return undef, "Undefined compartment $arg"; + } + } + } + # Stop characters + elsif ( $string_left =~ /^(\.|\+|\s+|)/ ) + { + last; + } + # Stop at unrecognized syntax + else + { + last; + } + } + + $$strptr = $string_left; + return ''; +} + + + +### +### +### + + + +sub toString +{ + my $mol = shift @_; + my $print_edges = @_ ? shift @_ : TRUE; + my $print_attributes = @_ ? shift @_ : TRUE; + my $speciesCompartment = @_ ? shift @_ : undef; + my $print_options = @_ ? shift @_ : (); + + my $string .= $mol->Name; + + $string .= sprintf("~%s", $mol->State) if (defined $mol->State); + + if ($print_attributes) + { $string .= sprintf("%%%s", $mol->Label) if (defined $mol->Label); } + + if ( defined $mol->Edges ) + { + if ( $print_edges) + { + my $wildcard = ""; + foreach my $edge ( @{$mol->Edges} ) + { + if ( $edge =~ /^\d+$/ ) + { $string .= sprintf "!%d", $edge + 1; } + else + { $wildcard = "!$edge"; } + $string .= $wildcard; + } + } + else + { $string .= "!" x scalar( @{$mol->Edges} ); } + } + + if ( defined $mol->Components ) + { + my $icomp = 0; + $string .= "("; + foreach my $comp ( @{$mol->Components} ) + { + if ($icomp) + { $string .= ','; } + if(exists $print_options->{'sbml_multi'}) + { + my $tmpstr .= $comp->toSBMLMultiSpeciesTypeString(); + if(!$tmpstr eq ''){ + $string .= $tmpstr; + ++$icomp; + } + } + else + { + $string .= $comp->toString($print_edges, $print_attributes); + ++$icomp; + } + + } + $string .= ")"; + } + else + { $string .= "()"; } + + if ( defined $mol->Compartment ) + { + unless ( (defined $speciesCompartment) and ($mol->Compartment == $speciesCompartment) ) + { $string .= sprintf "@%s", $mol->Compartment->Name; } + } + + # attributes + if ($print_attributes) + { + my @attr = (); + if ( $mol->Context ) + { push @attr, "Context"; } + if (@attr) + { $string .= '{' . join( ',', @attr ) . '}'; } + } + + return $string; +} + + + +### +### +### + + + +sub toStringSSC +{ + my $mol = shift @_; + + my $mname = $mol->Name; + my $string .= $mol->Name; + + my %checkComp; # A hash to check same component names + my $sameCompExists = 0; # Have we found repeated components? (This doesn't do anything now) + + $string .= '('; + my $icomp = 0; + foreach my $comp (@{$mol->Components}) + { + unless ($icomp == 0) { $string .= ','; } + + if (defined $comp->Name) + { + my $cname = $comp->Name; + if (exists $checkComp{$cname}) + { + $checkComp{$cname} = ++$checkComp{$cname}; + + print "\n same component exists for $mname \n"; + print " SSC rules do not handle components with same name \n"; + print" In this preliminary version of BNG-SSC translator we do not handle this case"; + } + else + { + $checkComp{$cname} = 0; + } + + if ( $sameCompExists == 0 ) { $string .= $comp->toStringSSC(); } + } + ++$icomp; + } + + $string .= ')'; + return $string, 0; +} + + + +### +### +### + + + +# a subroutine which fetches the number of same components in a molecule. +# returns a hash. key = name of teh component; value = no. of same components +sub getCompHash +{ + my $mol = shift; + my $string .= $mol->Name; + my %checkComp; # A hash to check same component names + + if ( defined $mol->Components ) + { + foreach my $comp ( @{$mol->Components} ) + { + if ( defined $comp->Name ) + { + my $cname = $comp->Name; + if ( exists $checkComp{$cname} ) + { + $checkComp{$cname} = ++$checkComp{$cname}; + } + else + { + $checkComp{$cname} = 0; + } + } + } + } + return %checkComp; +} + +# this toString is just used in corresponding seed species block. +# As in SSC one only specifies molecules, molecules if they hava a defined states +# Or molecules with bonds. + +sub toStringSSCMol +{ + my $mol = shift @_; + my $print_edges = @_ ? shift @_ : TRUE; + + my $string = ''; + my $icomp = 0; + my $test = 0; + foreach my $comp ( @{ $mol->Components } ) { + if ( defined( $comp->Edges ) ) { + $test = 0; + foreach my $edge ( @{ $comp->Edges } ) { + if ( $edge =~ /^\d+$/ ) { + ++$test; + if ( $icomp != 0 ) { $string .= ","; } + if ( defined( $comp->State ) ) { + if ( $icomp == 0 ) { $string .= "("; } + $string .= $comp->toStringSSC(); + ++$icomp; + } #Dont do anything if state has a bond + #Changes already in toString of Component.pm + if ( ( !defined( $comp->State ) ) ) { + if ( $icomp == 0 ) { $string .= "("; } + $string .= $comp->Name . "#" . ( $edge + 1 ); + ++$icomp; + } + } + } + } + if ( $test == 0 ) { + if ( defined( $comp->State ) ) { + if ( $icomp == 0 ) { $string .= "("; } + if ( $icomp != 0 ) { $string .= ","; } + $string .= $comp->Name . "=\"" . $comp->State . "\""; + ++$icomp; + } + } + + } + + if ( $icomp != 0 ) { $string .= ")"; } + if ( $icomp == 0 ) { $string .= "()"; } + return ($string); +} + + + +### +### +### + + + +sub toStringMCell +{ + my $mol = shift @_; + my $print_edges = @_ ? shift @_ : TRUE; + my $print_attributes = @_ ? shift @_ : TRUE; + my $speciesCompartment = @_ ? shift @_ : ""; + + my $string .= $mol->Name; + + if ( defined( $mol->State ) ) { + #do something $string .= sprintf "~%s", $mol->State; + } + + if ( defined( $mol->Label ) ) { + #$string .= sprintf "%%%s", $mol->Label; + } + + if ( defined( $mol->Edges ) ) { + # do something + } + + if ( defined( $mol->Components ) ) { + #do something + } + + if ( defined( $mol->Compartment ) ) { + #do something + } + + return ($string); +} + + + +### +### +### + +######## +# returns information for the speciesFeature and outwardBindingSite belonging to species in sbml multi +###### +sub getSBMLMultiSpeciesFields +{ + my $mol = shift @_; + my $mtlist = shift @_; + my $indent = shift @_; + my $stid = shift @_; + my $mid = shift @_; + my $sbmlMultiSpeciesInfo_ref = shift @_; + my $speciesIdHash_ref = shift @_; + # list of references to sbml multi species type objects for this species + my $multiComponentHash_ref = shift @_; + + my $componentIndexes = shift @_; + # Component information + #my $mid = sprintf "${id}_M%d", $index; + + # create an emtpy compartment list for use below + my $clist = CompartmentList->new('Used'=>0); + + my $cindex = 1; + my $mtype = $mtlist->MolTypes->{$mol->Name}; + my @visitedComponents = (); + my %componentCopy = %{dclone(\%{$speciesIdHash_ref->{'Components'}})}; + foreach my $ctype (@{$mtype->Components}){ + my $componentFlag = 0; + if(@{$mol->Components}){ + foreach my $comp ( @{$mol->Components} ) + { + #if we already used this component skip it + unless(grep {$_ eq $comp} @visitedComponents) { + + if($comp->Name eq $ctype->Name){ + # mark this component as visited + push @visitedComponents, $comp; + my $outwardbonds = ''; + + if(exists $speciesIdHash_ref->{'BindingInformation'}{$mol->Name}{$comp->Name}){ + $outwardbonds = $comp->getSBMLMultiOutwardBonds( ' ' . $indent, $mol->Name,$mid."_C". $cindex, \%componentCopy, $multiComponentHash_ref ); + } + my $speciesfeatures = $comp->getSBMLMultiSpeciesFeature( ' ' . $indent, $mol->Name,$mid."_C". $cindex, \%componentCopy, $multiComponentHash_ref, () ); + if(not $outwardbonds eq ''){ + push @{$sbmlMultiSpeciesInfo_ref->{'outwardbonds'}}, $outwardbonds; + } + if(not $speciesfeatures eq ''){ + push @{$sbmlMultiSpeciesInfo_ref->{'speciesFeature'}}, $speciesfeatures; + } + + $componentFlag = 1; + last; + } + } + + } + } + #even if a component is not explicitly included in the species graph specification we still need to generate some specoes multi information about it + if ($componentFlag == 0){ + my $sg = SpeciesGraph->new; + my $string = ''; + if(exists $speciesIdHash_ref->{'BindingInformation'}{$mtype->Name}{$ctype->Name}){ + $string = sprintf("%s(%s!?)", $mtype->Name, $ctype->Name); + } + else{ + $string = sprintf("%s(%s)", $mtype->Name, $ctype->Name); + } + + $string =~ s/^\s+//; + #create a dummy species graph with the component we need + my $err = $sg->readString( \$string, $clist, 1, '^\s+', $mtlist ); + my $cnew = @{@{$sg->Molecules}[0]->Components}[0]; + + my $outwardbonds = ''; + if(exists $speciesIdHash_ref->{'BindingInformation'}{$mtype->Name}{$cnew->Name}){ + $outwardbonds = $cnew->getSBMLMultiOutwardBonds( ' ' . $indent, $mtype->Name,$mid."_C". $cindex, \%componentCopy, $multiComponentHash_ref ); + } + my $speciesfeatures = $cnew->getSBMLMultiSpeciesFeature( ' ' . $indent, $mtype->Name,$mid."_C". $cindex, \%componentCopy, $multiComponentHash_ref ); + if(not $outwardbonds eq ''){ + push @{$sbmlMultiSpeciesInfo_ref->{'outwardbonds'}}, $outwardbonds; + } + if(not $speciesfeatures eq''){ + push @{$sbmlMultiSpeciesInfo_ref->{'speciesFeature'}}, $speciesfeatures; + } + + } + + $cindex += 1; + + } + +} + +sub toXML +{ + my $mol = shift @_; + my $indent = shift @_; + my $id = shift @_; + my $index = (@_) ? shift @_ : ''; + + my $string = $indent . "Name . "\""; + # molecule label + if ( defined $mol->Label ) + { + $string .= " label=\"" . $mol->Label . "\""; + } + # compartment + if ( defined $mol->Compartment ) + { + $string .= " compartment=\"" . $mol->Compartment->Name . "\""; + } + + # Objects contained + my $indent2 = ' ' . $indent; + my $ostring = ''; + + # Molecules + if ( @{$mol->Components} ) + { + $ostring .= $indent2 . "\n"; + my $cindex = 1; + foreach my $comp ( @{$mol->Components} ) + { + $ostring .= $comp->toXML( ' ' . $indent2, $mid, $cindex ); + ++$cindex; + } + $ostring .= $indent2 . "\n"; + } + + # Termination + if ($ostring) + { # terminate tag opening + $string .= ">\n"; + $string .= $ostring; + $string .= $indent . "\n"; + } + else + { # short tag termination + $string .= "/>\n"; + } + + return $string; +} + + + +### +### +### + + + +# make exact copy of molecule +sub copy +{ + # get molecule that we want to copy + my $mol = shift; + # should we copy labels? + my $copy_labels = (@_) ? shift : 1; + # add prefix to edges + my $prefix = (@_) ? shift : ''; + + # create new molecule + my $mol_copy = Molecule->new(); + + # copy scalar attributes + $mol_copy->Name( $mol->Name ); + $mol_copy->State( $mol->State ); + $mol_copy->Label( $mol->Label ) if ($copy_labels); + $mol_copy->Context( $mol->Context ); + $mol_copy->Compartment( $mol->Compartment ) if (defined $mol->Compartment); + + # copy edges + if ( @{$mol->Edges} ) + { + # add prefix to edge label, unless its a wildcard + $mol_copy->Edges( [map {$_=~/^[*+?]$/ ? $_ : $prefix.$_} @{$mol->Edges}] ); + } + # copy components + if ( @{$mol->Components} ) + { + $mol_copy->Components( [map {$_->copy($copy_labels,$prefix)} @{$mol->Components} ] ); + } + + # return molecule copy + return $mol_copy; +} + + +### +### +### + + +# call this method to link Compartments to a new CompartmentList +sub relinkCompartments +{ + my $mol = shift; + my $clist = shift; + + my $err; + unless ( ref $clist eq 'CompartmentList' ) + { return "Molecule->relinkCompartments: Error!! Method called without CompartmentList object"; } + + if ( defined $mol->Compartment ) + { + my $new_comp = $clist->lookup( $mol->Compartment->Name ); + unless ($new_comp) + { return "Molecule->relinkCompartments: Error!! could not find compartment name in list"; } + $mol->Compartment( $new_comp ); + } + + foreach my $comp ( @{$mol->Components} ) + { + $err = $comp->relinkCompartments( $clist ); + if (defined $err) { return $err; } + } + + return undef; +} + + + +### +### +### + + + +# Molecule comparison for isomorphism +sub compare_local +{ + my $a = shift; + my $b = shift; + + my $cmp; + + # Molecule name + if ( $cmp = ($a->Name cmp $b->Name) ) + { return $cmp; } + + # Molecule state + if ( $cmp = ($a->State cmp $b->State) ) + { return $cmp; } + + # Molecule compartment + if ( $cmp = ( $a->Compartment->Name cmp $b->Compartment->Name ) ) + { return $cmp; } + + # Number of edges + if ( $cmp = (@{$a->Edges} <=> @{$b->Edges}) ) + { return $cmp; } + + # Number of Components + if ( $cmp = (@{$a->Components} <=> @{$b->Components}) ) + { return $cmp; } + + # Components + for ( my $ic = 0; $ic < @{$a->Components}; ++$ic ) + { + if ( $cmp = $a->Components->[$ic]->compare($b->Components->[$ic]) ) + { return $cmp; } + } + + return 0; +} + + + +### +### +### + +1; diff --git a/libvcell/vcell_install/bionetgen/Perl2/MoleculeType.pm b/libvcell/vcell_install/bionetgen/Perl2/MoleculeType.pm new file mode 100644 index 0000000..0e4fd66 --- /dev/null +++ b/libvcell/vcell_install/bionetgen/Perl2/MoleculeType.pm @@ -0,0 +1,585 @@ +# Objects for typing and checking Molecules +package MoleculeType; + +# pragmas +use strict; +use warnings; + +# Perl Modules +use Class::Struct; +use FindBin; +use lib $FindBin::Bin; + +# BNG Modules +use Molecule; +use ComponentType; + + + +struct MoleculeType => +{ + Name => '$', + Components => '@', # Array of ComponentTypes + PopulationType => '$', # Is this a population type molecule? +}; + + +### +### +### + + +# read a molecule type from the Molecle Types block +sub readString +{ + my $mtype = shift @_; + my $strptr = shift @_; + + my $string_left = $$strptr; + + # Get molecule name (alphanumeric ID, must begin with a letter or underscore) + if ( $string_left =~ s/^([A-Za-z_]\w*)// ) + { + my $name= $1; + $mtype->Name($1); + } + else + { + return ("Invalid MoleculeType name at '$$strptr' (must begin with a letter or underscore)." ); + } + + # By default, set population tag false + $mtype->PopulationType(0); + + # Get molecule state (marked by ~) edges (marked by !) and label (marked by + # %) and components (enclosed in ()) + my @elabels=(); + my @components=(); + while($string_left) + { + # Read components in parentheses + if ( $string_left =~ s/^[(]// ) + { + if ( @components ) + { + return("Multiple component definitions"); + } + + while ( $string_left ) + { + # Continue characters + if ( $string_left =~ s/^[,.]// ) + { + next; + } + # Stop characters + elsif ( $string_left =~ s/^[)]\s*// ) + { + last; + } + # Read + else + { + my $comp = ComponentType->new; + my $err = $comp->readString(\$string_left); + if ($err) { return ($err); } + push @components, $comp; + } + } + } + # Strip white space + # (NOTE: this used to be a stop character. Will removing this cause problems? --Justin, 7mar2011) + elsif ( $string_left =~ s/^\s+// ) + { + # nothing to do here + } + # Stop characters + elsif ( $string_left =~ /^[,.]|[<]?-[>]/ ) + { + last; + } + # Look for population tag + elsif ( $string_left =~ s/^population\s*//i ) + { + $mtype->PopulationType(1); + } + else + { + return ("Invalid MoleculeType specification $$strptr"); + } + } + + if (@components) + { + ### Make sure identical components have identical states ### + # Loop over component i + for (my $i=0; $i < scalar(@components); $i++){ + # Loop over component j > i + for (my $j=$i+1; $j < scalar(@components); $j++){ + # Check if names are the same + if ($components[$i]->Name eq $components[$j]->Name){ + # Quit if components have unequal numbers of states + if (scalar @{$components[$i]->States} ne scalar @{$components[$j]->States}){ + return ("Invalid MoleculeType specification $$strptr"); + } + # Compare state values element-by-element + else{ + # Sort component states + @{$components[$i]->States} = sort @{$components[$i]->States}; + @{$components[$j]->States} = sort @{$components[$j]->States}; + for (my $k=0; $k < scalar @{$components[$i]->States}; $k++){ + # Quit if elements are different + if (@{$components[$i]->States}[$k] ne @{$components[$j]->States}[$k]){ + return ("Invalid MoleculeType specification $$strptr"); + } + } + } + } + } + } + $mtype->Components([@components]); + } + $$strptr = $string_left; + + return ''; +} + + +### +### +### + +sub copy +{ + my $mt = shift; + + my $mt_copy = MoleculeType::new(); + $mt_copy->Name( $mt->Name ); + foreach my $comp ( @{$mt->Components} ) + { + push @{$mt_copy->Components}, $comp->copy(); + } + $mt_copy->PopulationType( $mt->PopulationType ); + + return $mt_copy; +} + + +### +### +### + + +sub add +{ + my $mtype = shift @_; + my $mol = shift @_; + + $mtype->Name($mol->Name); + my @ctarray = (); + foreach my $comp (@{$mol->Components}) + { + my $ctype=ComponentType->new( Name=>$comp->Name ); + # The first entry in the States array becomes the default state value + my $state = $comp->State; + if (defined $state and $state ne '') + { + $ctype->States(0, $state); + } + push @ctarray, $ctype; + } + $mtype->Components([@ctarray]); + return ''; +} + + + +### +### +### + + + +sub check +{ + my $mtype = shift @_; + my $mol = shift @_; + my $params = @_ ? shift @_ : {}; + + my $IsSpecies = exists $params->{IsSpecies} ? $params->{IsSpecies} : 1; + my $AllowNewStates = exists $params->{AllowNewTypes} ? $params->{AllowNewTypes} : !$IsSpecies; + my $AllowPartial = !$IsSpecies; + my $AllowWildcard = !$IsSpecies; + my $AllowUndefinedStates = !$IsSpecies; + my $InheritList = exists $params->{InheritList} ? $params->{InheritList} : 0; + + my @ctypes = @{$mtype->Components}; + + foreach my $comp (@{$mol->Components}) + { + my $found=0; + my $index=0; + # Check for match for each component + foreach my $comp_type (@ctypes) + { + if ($comp->Name eq $comp_type->Name) + { + my $state = $comp->State; + if ( !defined $state ) + { + # If component state is undefined, check whether component states have been declared, meaning this + # component should not be stateless, unless AllowUndefinedStates is true + my $InheritState = ($InheritList) ? $InheritList->[$index] : 0; + #print "IS= $InheritState\n"; + if (@{$comp_type->States} && !$InheritState && !$AllowUndefinedStates) + { + my $err= sprintf "State of component %s of molecule %s must be set", + $comp->Name, $mol->toString(); + return($err); + } + } + elsif ($state=~/^[?]$/) + { + unless ($AllowWildcard) + { + my $err="May not use wildcard for component state in species."; + return $err; + } + } + else + { + # If component state is defined, check whether no component states have been declared, meaning this + # component should be stateless + unless (@{$comp_type->States}) + { + my $err = sprintf "Component %s of molecule %s does not accept states", + $comp->Name, $mol->toString(); + return $err; + } + + # Check that $state matches allowed states for this component + my $sfound=0; + foreach my $comp_state (@{$comp_type->States}) + { + if ($state eq $comp_state) + { + $sfound=1; + last; + } + } + unless ($sfound) + { + if ($AllowNewStates) + { + printf "Adding %s as allowed state of component %s of molecule %s\n", + $comp->State, $comp->Name, $mol->Name; + push @{$comp_type->States}, $comp->State; + } + else + { + my $err= sprintf "Component state %s of component %s of molecule %s not" + . "defined in molecule declaration", + $comp->State, $comp->Name, $mol->toString(); + return($err); + } + } + } + + if ( $IsSpecies ) + { # check for bond wildcards + if ( grep {$_ =~ /^[+?]$/} @{$comp->Edges} ) + { + my $err = sprintf "Component %s of molecule %s has an illegal bond wildcard.", + $comp->Name, $mol->toString(); + return $err; + } + } + + # Delete component type from search array + splice @ctypes, $index, 1; + $found = 1; + last; + } + ++$index; + } + unless ($found) + { + my $err = sprintf "Component %s of molecule %s not found in molecule declaration", $comp->Name, $mol->toString(); + return $err; + } + } + + # Incomplete specification of molecule components + if (!$AllowPartial and @ctypes) + { + my $names = ""; + foreach my $ct (@ctypes) + { + $names .= " ".$ct->Name; + } + my $err = sprintf "Component(s)${names} missing from molecule %s", $mol->toString(); + return $err; + } + + return ''; +} + + + +### +### +### + + + +sub toString +{ + my $mtype = shift; + my $max_length = (@_) ? shift : 0; + + # get name + my $string = $mtype->Name; + # get components + my @cstrings = (); + foreach my $comp ( @{$mtype->Components} ) + { + push @cstrings, $comp->toString(); + } + $string .= '(' . join(',', @cstrings) . ')'; + + if ( $max_length ) + { # pad with extra spaces so things line up + my $string_len = length $string; + if ( $string_len <= $max_length ) + { + $string .= ' ' x ($max_length - $string_len); + } + } + + # write population tag is not written to output! + if ( $mtype->PopulationType ) + { $string .= " population"; } + + return $string; +} + + +### +### +### + + +sub toStringSSC +{ + my $mtype = shift; + my $string = ''; + + $string .= $mtype->Name; + + my @cstrings; + @cstrings = (); + foreach my $comp (@{$mtype->Components}) + { + push @cstrings, $comp->toStringSSC(); + } + $string .= '(' . join(',', @cstrings) . ')'; + + # NOTE: SSC won't recognize population tag, so dont output. --Justin + return $string; +} + + +##### +# information used to create speciestype object in sbml multi +##### +sub toSBMLMultiSpeciesType +{ + my $mtype = shift @_; + my $sid = shift @_; + my $mid = shift @_; + my $index = shift @_; + my $indent = shift @_; + my $sbmlMultiSpeciesInfo_ref = shift @_; + my $speciesIdHash_ref = shift @_; + + + + # appends the length of the $sbmlMultiSpeciesInfo_ref hash + my $stid = "ST_M" . keys(%$sbmlMultiSpeciesInfo_ref); + my $stinstance_string = ''; + if (exists $sbmlMultiSpeciesInfo_ref->{$mtype->toString()} ){ + $stid = $sbmlMultiSpeciesInfo_ref->{$mtype->toString()}[0]; + $stinstance_string = sprintf("%s\n",$indent, $mid, $mtype->Name, $stid); + + }else{ + $stinstance_string = sprintf("%s\n",$indent, $mid, $mtype->Name, $stid); + } + my $st_string = sprintf("\n", $stid, $mtype->Name, "cell"); + + # add id information + + $speciesIdHash_ref->{'Molecules'}->{$mtype->Name} = $stid; + + push @{$speciesIdHash_ref->{'References'}->{$sid}->{'Molecules'}->{$stid}}, sprintf("cmp_%s_M", $sid) . "$index"; + push @{$speciesIdHash_ref->{'References'}->{$sid}->{'moleculeReverseReferences'}->{$mtype->Name()}}, $mid ; + + if (@{$mtype->Components}) + { + my $indent2 = " ".$indent; + my $counter = 1; + + my $tempstr = ''; + my $cid = ''; + + + my $tmp_string = ''; + + foreach my $comp (@{$mtype->Components}) + { + $cid = sprintf("%s_C%d",$stid, $counter); + # only check things that are explicit binding sites + if (exists $speciesIdHash_ref->{'BindingInformation'}{$mtype->Name}{$comp->Name}){ + # store the species id for use in the species section + $tempstr = $comp->toSBMLMultiSpeciesTypeBinding($cid, $mtype->Name, $sbmlMultiSpeciesInfo_ref, $speciesIdHash_ref, $indent2); + if($tempstr ne ''){ + push @{$speciesIdHash_ref->{'References'}->{$sid}->{'reverseReferences'}->{sprintf("%s(%s~", $mtype->Name, $comp->Name)}}, $mid . "_C${counter}"; + push @{$speciesIdHash_ref->{'References'}->{$sid}->{'reverseReferences'}->{sprintf("%s(%s)", $mtype->Name, $comp->Name)}}, $mid . "_C$counter"; + $speciesIdHash_ref->{'References'}->{$sid}->{'Components'}->{$mid . "_C$counter"}->{'id'} = sprintf("cmp_%s_M", $sid) . "$index" ."_C$counter"; + $speciesIdHash_ref->{'References'}->{$sid}->{'Components'}->{$mid . "_C$counter"}->{'parent'} = $mid; + $speciesIdHash_ref->{'References'}->{$sid}->{'Components'}->{$mid . "_C$counter"}->{'parentMulti'} = $cid; + + $tmp_string .= $tempstr; + } + } + $counter += 1; + + } + $counter = 1; + foreach my $comp (@{$mtype->Components}){ + $cid = sprintf("%s_C%d",$mid, $counter); + $counter +=1; + } + unless ($tmp_string eq ''){ + $st_string .= $indent."\n"; + $st_string .= $tmp_string; + $st_string .= $indent."\n"; + } + + + $counter = 1; + my $featuretypes =''; + foreach my $comp (@{$mtype->Components}) + { + # only check things that are not binding sites. Hybrids are alraedy accoutned for + if (! exists $speciesIdHash_ref->{'BindingInformation'}{$mtype->Name}{$comp->Name}){ + + $cid = sprintf("%s_C%d",$stid, $counter); + + $tempstr = $comp->toSBMLMultiSpeciesTypeFeatures($cid, $mtype->Name, $sbmlMultiSpeciesInfo_ref, $speciesIdHash_ref, $indent2); + if($tempstr ne ''){ + push @{$speciesIdHash_ref->{'References'}->{$sid}->{'reverseReferences'}->{sprintf("%s(%s~", $mtype->Name, $comp->Name)}}, $mid . "_C${counter}"; + push @{$speciesIdHash_ref->{'References'}->{$sid}->{'reverseReferences'}->{sprintf("%s(%s)", $mtype->Name, $comp->Name)}}, $mid . "_C$counter"; + #$speciesIdHash_ref->{'References'}->{$sid}->{'Components'}->{$mid . "_C$counter"}->{'id'} = sprintf("%sI_M", $sid) . "$index" ."_C$counter"; + #$speciesIdHash_ref->{'References'}->{$sid}->{'Components'}->{$mid . "_C$counter"}->{'parent'} = $mid; + #$speciesIdHash_ref->{'References'}->{$sid}->{'Components'}->{$mid . "_C$counter"}->{'parentMulti'} = $cid; + $featuretypes .= $tempstr; + } + } + $counter += 1; + + } + if(! $featuretypes eq ''){ + $st_string .= $indent. "\n"; + $st_string .= $featuretypes; + $st_string .= $indent. "\n"; + + } + + + + + + } + + + $st_string .= $indent. "\n"; + if (! exists $sbmlMultiSpeciesInfo_ref->{$mtype->toString()} ){ + + push @{$sbmlMultiSpeciesInfo_ref->{$mtype->toString()}}, $stid; + push @{$sbmlMultiSpeciesInfo_ref->{$mtype->toString()}}, $st_string; + } + return $stinstance_string; +} + +### +### +### + + +sub toXML +{ + my $mtype = shift; + my $indent = shift; + my $string = $indent."Name."\""; + # population type + if ( $mtype->PopulationType ) { $string .= " population=\"1\""; } + + # Objects + my $indent2 = ' '.$indent; + my $ostring = ''; + # Component list + if (@{$mtype->Components}) + { + $ostring .= $indent2."\n"; + foreach my $comp (@{$mtype->Components}) + { + $ostring .= $comp->toXML(" ".$indent2); + } + + $ostring .= $indent2."\n"; + } + + if ($ostring) + { + $string .= ">\n"; # terminate tag opening + $string .= $ostring; + $string .= $indent."\n"; + } + else + { + $string .= "/>\n"; # short tag termination + } + + return $string; +} + +sub writeMDL +{ + my $mtype = shift; + my $string = ""; + + $string = $mtype->Name; + $string .= "("; + + if (@{$mtype->Components}) + { + my $k = 0; + foreach my $comp (@{$mtype->Components}) + { + if ($k) + {$string .=",";} + $string .= $comp->writeMDL(); + $k = 1; + } + + } + $string .= ")"; + return $string; +} + + +1; diff --git a/libvcell/vcell_install/bionetgen/Perl2/MoleculeTypesList.pm b/libvcell/vcell_install/bionetgen/Perl2/MoleculeTypesList.pm new file mode 100644 index 0000000..edb163a --- /dev/null +++ b/libvcell/vcell_install/bionetgen/Perl2/MoleculeTypesList.pm @@ -0,0 +1,402 @@ +# $Id: MoleculeTypesList.pm,v 1.4 2006/09/13 03:44:06 faeder Exp $ + +# List of MoleculeType objects +package MoleculeTypesList; + +# pragmas +use strict; +use warnings; +no warnings 'redefine'; + +# Perl Modules +use Class::Struct; +use FindBin; +use lib $FindBin::Bin; + +# BNG Modules +use MoleculeType; +use SpeciesGraph; +use Molecule; + + + + +struct MoleculeTypesList => +{ + MolTypes => '%', + StrictTyping => '$' +}; + + + +### +### +### + + + +sub readString +{ + my $mtl = shift; + my $entry = shift; + + # Check if token is an index + # DEPRECATED as of BNG 2.2.6 + if ($entry=~ s/^\s*(\d+)\s+//) + { + return "Leading index detected at '$entry'. This is deprecated as of BNG 2.2.6."; + } + + # Remove leading label, if exists + if ($entry =~ s/^\s*(\w+)\s*:\s+//) + { + # Check label for leading number + my $label = $1; + if ($label =~ /^\d/) { return "Syntax error (label begins with a number) at '$label'."; } + } + + # Next token is string for species graph + $entry =~ s/^\s*//; + my $mt = MoleculeType->new; + my $err = $mt->readString( \$entry, 1, '', $mtl ); + if ($err) { return($err); } + if ($entry =~ /\S+/) + { + return "Syntax error in MoleculeType declaration"; + } + + # Check if type previously defined + if ( $mtl->MolTypes->{$mt->Name} ) + { + $err = sprintf "Molecule type %s previously defined.", $mt->Name; + return $err; + } + + # Create new MoleculeType entry + $mtl->MolTypes->{$mt->Name} = $mt; + + return ''; +} + + + +### +### +### + + +sub getNumMolTypes +{ + my $mtlist = shift; + return scalar keys %{$mtlist->MolTypes}; + +} + + +### +### +### + + + +# get a copy of a moleculeTypesList, along with copies of all the moleculeTypes +sub copy +{ + my $mtlist = shift; + + my $mtlist_copy = MoleculeTypesList::new(); + while ( my ($name,$mt) = each %{$mtlist->MolTypes} ) + { + my $mt_copy = $mt->copy(); + $mtlist_copy->MolTypes->{$mt_copy->Name} = $mt_copy; + } + $mtlist_copy->StrictTyping( $mtlist->StrictTyping ); + + return $mtlist_copy; +} + + + +### +### +### + + + +# add a moleculeType to the list +sub add +{ + my $mtlist = shift; + my $mt = shift; + + if ( exists $mtlist->MolTypes->{$mt->Name} ) + { # molecule type is already in list + return 0; + } + else + { # add molecule type to list + $mtlist->MolTypes->{$mt->Name} = $mt; + return 1; + } +} + + + +### +### +### + + + +# find a moleculeType by name +sub findMoleculeType +{ + my $mtl = shift; + my $name = shift; + + my $mt = undef; + if ( exists $mtl->MolTypes->{$name} ) + { + $mt = $mtl->MolTypes->{$name}; + } + return $mt; +} + + + +### +### +### + + +# Check whether Molecules in SpeciesGraph match declared types +# Set $params->{IsSpecies} to 1 to force all components to be +# declared with defined states (if states are defined for the component) +sub checkSpeciesGraph +{ + my $mtl = shift; + my $sg = shift; + my $params = (@_) ? shift : ''; + + my $IsSpecies = (defined $params->{IsSpecies} ) ? $params->{IsSpecies} : 1; + my $AllowNewTypes = (defined $params->{AllowNewTypes}) ? $params->{AllowNewTypes} : 0; + + foreach my $mol (@{$sg->Molecules}) + { + my $mtype; + if ($mol->Name =~ /[*]/) + { + my $found_match=0; + # Handle mol names containing wildcards + foreach $mtype (keys %{$mtl->MolTypes}) + { + next unless ($mol->Name =~ $mtype); + if ( $mtype->check($mol,$params) eq '' ) + { + ++$found_match; + } + unless ($found_match) + { + my $err = sprintf "Molecule string %s does not match any declared molecule types", $mol->toString(); + return $err; + } + } + } + elsif ( $mtype = $mtl->MolTypes->{$mol->Name} ) + { + # Validate against declared type + if ( my $err = $mtype->check($mol,$params) ) + { + return $err; + } + } + else + { + # Type not found. + if ($AllowNewTypes) + { + #Define a new type + my $mtype= MoleculeType->new; + $mtype->add($mol); + $mtl->MolTypes->{$mol->Name} = $mtype; + } + else + { + my $err = sprintf "Molecule %s does not match any declared molecule types", $mol->toString(); + #$err.= "\n".$mtl->writeBNGL(); + return $err; + } + } + } + + return ''; +} + + + +### +### +### + + + +sub checkMolecule +{ + my $mtl = shift @_; + my $mol = shift @_; + my $params = @_ ? shift @_ : {}; + + my $IsSpecies = exists $params->{IsSpecies} ? $params->{IsSpecies} : 1; + my $AllowNewTypes = exists $params->{AllowNewTypes} ? $params->{AllowNewTypes} : 0; + + my $mtype; + if ( $mtype = $mtl->MolTypes->{$mol->Name} ) + { + # Validate against declared type + if ( my $err = $mtype->check($mol,$params) ) + { return $err; } + } + else + { + # Type not found. + if ($AllowNewTypes) + { + # Define a new type + my $mtype = MoleculeType->new; + $mtype->add($mol); + $mtl->MolTypes->{$mol->Name} = $mtype; + } + else + { + my $err = sprintf "Molecule %s does not match any declared molecule types", $mol->toString(); + return $err; + } + } + + return ''; +} + + + +### +### +### + + + +sub writeBNGL +{ + my $mtlist = shift @_; + my $user_params = @_ ? shift @_ : { 'pretty_formatting'=>0 }; + + my $max_length = 0; + if ( $user_params->{pretty_formatting} ) + { # find longest molecule type string + while ( my ($name, $mt) = each %{$mtlist->MolTypes} ) + { + my $string = $mt->toString(); + $max_length = ( length $string > $max_length ) ? length $string : $max_length; + } + } + + my $out = "begin molecule types\n"; + my $index = 1; +# while ( my ($name, $mt) = each %{$mtlist->MolTypes} ) + foreach my $key (sort keys %{$mtlist->MolTypes}) + { + my $mt = $mtlist->MolTypes->{$key}; + if ( $user_params->{pretty_formatting} ) + { # no molecule type index + $out .= ' ' . $mt->toString($max_length) . "\n"; + } + else + { # include index + $out .= sprintf "%5d %s\n", $index, $mt->toString(); + } + + ++$index; + } + $out .= "end molecule types\n"; + + return $out; +} + + +##### +# information used to create speciestype object in sbml multi +##### +sub toSBMLMultiSpeciesType +{ + my $mtl = shift @_; + my $sg = shift @_; + my $sid = shift @_; + my $indent = shift @_; + my $sbmlMultiSpeciesInfo_ref = shift @_; + my $speciesIdHash_ref = shift @_; + + my $index = 1; + my $ostring = ''; + my $mtype; + my $mid = ''; + my $n_mol = scalar( @{ $sg->Molecules } ); + # molecules can only contain speciestype instances so we dont have to worry about species-level feature type for now + + $ostring .= $indent . "\n"; + foreach my $mol (@{$sg->Molecules}) + { + if($mtype = $mtl->MolTypes->{$mol->Name}){ + $mid = sprintf("%s_M%s", $sid, $index); + # if($n_mol > 1) { + # $mid = sprintf("%s_M%s", $sid, $index); + # } + # else{ + # $mid = $sid; + # } + $ostring .= $mtype->toSBMLMultiSpeciesType($sid, $mid, $index, " ". $indent, $sbmlMultiSpeciesInfo_ref, $speciesIdHash_ref); + } + + $index += 1; + } + $ostring .= $indent . "\n"; + + return $ostring; + +} + + +### +### +### + + +sub toXML +{ + my $mtlist = shift; + my $indent = shift; + my $string = $indent."\n"; + # loop over molecule types + foreach my $mname (sort keys %{$mtlist->MolTypes}) + { + my $mt = $mtlist->MolTypes->{$mname}; + $string .= $mt->toXML(" ".$indent); + } + $string .= $indent."\n"; + return $string; +} + +sub writeMDL +{ + my $mtlist = shift; + my $indent = shift; + my $string = ""; + # loop over molecule types + foreach my $mname (sort keys %{$mtlist->MolTypes}) + { + my $mt = $mtlist->MolTypes->{$mname}; + $string .= $indent.$mt->writeMDL()."\n"; + } + return $string; +} + + +1; diff --git a/libvcell/vcell_install/bionetgen/Perl2/Observable.pm b/libvcell/vcell_install/bionetgen/Perl2/Observable.pm new file mode 100644 index 0000000..a66e328 --- /dev/null +++ b/libvcell/vcell_install/bionetgen/Perl2/Observable.pm @@ -0,0 +1,756 @@ +package Observable; + +# pragmas +use strict; +use warnings; +no warnings 'redefine'; + +# Perl Modules +use Class::Struct; +use FindBin; +use lib $FindBin::Bin; + +# BNG Modules +use BNGUtils; +use BNGModel; +use SpeciesGraph; + + + +# Members +struct Observable => +{ + Name => '$', + Patterns => '@', + Weights => '@', + Type => '$', + Output => '$', # If false, suppress output. (Feature not yet implemented) +}; + +my $print_match=0; + +### +### +### + + +sub copy +{ + my $obs = shift @_; + + my $obs_copy = Observable->new( Name=>$obs->Name, Type=>$obs->Type, Output=>$obs->Output ); + + foreach my $patt ( @{$obs->Patterns} ) + { + my $patt_copy = $patt->copy(); + push @{$obs_copy->Patterns}, $patt_copy; + } + + if ( defined $obs->Weights ) + { $obs_copy->Weights( [@{$obs->Weights}] ); } + + return $obs_copy; +} + + +### +### +### + + +# call this method to link Compartments to a new CompartmentList +sub relinkCompartments +{ + my $obs = shift @_; + my $clist = shift @_; + + my $err = undef; + unless ( ref $clist eq 'CompartmentList' ) + { return "Observable->relinkCompartments: Error!! Method called without CompartmentList object"; } + + foreach my $patt ( @{$obs->Patterns} ) + { + $err = $patt->relinkCompartments( $clist ); + if (defined $err) { return $err; } + } + + return undef; +} + + +### +### +### + + +sub readString +{ + my $obs = shift @_; + my $string = shift @_; + my $model = shift @_; + + my $err; + + # set output true (by default) + $obs->Output(1); + + # Remove leading whitespace + $string =~ s/^\s*//; + + # Check if first token is an index (This index will be ignored) + # DEPRECATED as of BNG 2.2.6 + if ( $string =~ s/^\s*\d+\s+// ) + { + return "Leading index detected at '$string'. This is deprecated as of BNG 2.2.6."; + } + + # Remove leading label, if exists + if ( $string =~ s/^\s*(\w+)\s*:\s+// ) + { + # Check label for leading number + my $label = $1; + if ($label =~ /^\d/) { return "Syntax error (label begins with a number) at '$label'"; } + } + + # Check name for leading number + my $string_left = $string; + unless ( $string_left =~ s/^([A-Za-z_]\w*)// ) + { + return "Syntax error (observable name begins with a number) at '$string'"; + } + + # Check if next token is observable type + # Adding Counter and Population types --Justin, 5nov2010 + # Function observable is undocumenterd, but its here to include function + # evaluations among the output observables --Justin + if ( $string =~ s/^\s*(Molecules|Species|Counter)\s*// ) + { + # record observable type + $obs->Type($1); + } + else + { # Justin thinks defaults like this are dangerous and prone to unpredictable behavior + # when future changes are made to the language or code. Return error instead + return "Observable type is not valid"; + } + + # Next token is observable Name + if ( $string =~ s/^\s*([A-z]\w*)\s+// ) + { + my $name=$1; + $obs->Name($name); + } + else + { + my ($name) = split(' ', $string); + return "Invalid observable name $name: may contain only alphnumeric and underscore"; + } + + # Define parameter with name of the Observable + if ( $model->ParamList->set( $obs->Name, "0", 1, "Observable", $obs) ) + { + my $name= $obs->Name; + return "Observable name $name matches previously defined Observable or Parameter"; + } + + # Remaining entries are patterns + my $sep = '^\s+|^\s*,\s*'; + while ($string) + { + my $g = SpeciesGraph->new(); + my $count_autos = 1; + $err = $g->readString( \$string, $model->CompartmentList, 0, $sep, $model->MoleculeTypesList, $count_autos ); + if ($err) { return "While reading observable " . $obs->Name . ": $err"; } + + $string =~ s/$sep//; + + if ( $g->isNull() ) + { # this is the null pattern + send_warning( sprintf("Found useless instance of null pattern in observable %s.", $obs->Name) ); + next; + } + + if ( ($obs->Type eq 'Species') and (not defined($g->Quantifier) or $g->Quantifier eq '') ) + { + $g->MatchOnce(1); + } + push @{$obs->Patterns}, $g; + } + + return $err; +} + + +### +### +### + + +# reset the observable weights to zero +sub reset_weights +{ + my $obs = shift @_; + my $alloc = @_ ? shift @_ : 0; + $obs->Weights( [(0) x ($alloc+1)] ); +} + + +### +### +### + +#####################################DB################################# +sub writeMDL +{ + my $obs = shift @_; + my $string = ""; + my $indent = " "; + + $string .= "\n$indent/*".$obs->Name."*/\n"; + my $i = -1; + my $first = 1; + + $string .= $indent."{ "; + foreach my $w (@{$obs->Weights}){ + ++$i; + next unless $w; + $string .= " + " unless $first; + $string .= sprintf("%sCOUNT[s%s,WORLD]", $w > 1 ? $w."*" : "", $i); + $first = 0; + } + $string .= sprintf(" }=> \"./react_data/%s.dat\"\n",$obs->Name); + return $string; +} + +############ + +# try to match observable to a speciesGraph and return the number of matches +sub match +{ + my $obs = shift @_; + my $sg = shift @_; + my $root_src = @_ ? shift @_ : -1; + my $root_targ = @_ ? shift @_ : -1; + #printf STDOUT "Observable::match(obs=%s, sg=%s, rootmol=%s)\n", $obs->Name, $sg->toString(), $root_targ; + + my $total_matches = 0; + if ($obs->Type eq "Molecules") + { + my $mode = 0; + if (exists $BNGModel::GLOBAL_MODEL->Options->{MoleculesObservables}) + { + if ( $BNGModel::GLOBAL_MODEL->Options->{MoleculesObservables} eq "CountUnique" ) + { $mode = 1; } + } + + foreach my $patt (@{$obs->Patterns}) + { + # find matches of this pattern in species graph + my @matches = $patt->isomorphicToSubgraph( $sg, $root_src, $root_targ ); + if (@matches) + { + ## SYMMETRY CORRECTION is disabled for the time being! + if ($mode) + { $total_matches += scalar @matches / $patt->Automorphisms; } + else + { $total_matches += scalar @matches; } + } + } + } + elsif ($obs->Type eq "Species") + { + my $mode = 0; + if (exists $BNGModel::GLOBAL_MODEL->Options->{SpeciesObservables}) + { + if ( $BNGModel::GLOBAL_MODEL->Options->{SpeciesObservables} eq "CountUnique" ) + { $mode = 1; } + } + + foreach my $patt (@{$obs->Patterns}) + { + # find matches of this pattern in species graph + my @matches = $patt->isomorphicToSubgraph( $sg, $root_src, $root_targ ); + ## SYMMETRY CORRECTION is disabled for the time being! + #my $n_match = scalar @matches / $patt->Automorphisms; + my $n_match = scalar @matches; + + if ($patt->Quantifier) + { + my $test_string = $n_match . $patt->Quantifier; + my $result = eval $test_string; + warn $@ if $@; + $total_matches += $result ? 1 : 0; + last if ($mode); + } + elsif ($n_match>0) + { + $total_matches += 1; + last if ($mode); + } + } + + } + return $total_matches; +} + + +### +### +### + + +# compute observable weights for the species in the array +sub update +{ + my $obs = shift @_; + my $species = shift @_; + my $idx_start = @_ ? shift @_ : 0; + + my $err = ''; + + for ( my $ii = $idx_start; $ii < @$species; ++$ii ) + { + my $sp = $species->[$ii]; + next if ($sp->ObservablesApplied); + $obs->Weights->[$sp->Index] = $obs->match( $sp->SpeciesGraph ); + } + return $err; +} + + +### +### +### + + +# evaluate observable. +# If observable evaluation is scoped to a complex or molecule, +# the scope argument is the first element of @$args. +sub evaluate +{ + my $obs = shift @_; + my $args = @_ ? shift @_ : []; + my $plist = @_ ? shift @_ : undef; + my $level = @_ ? shift @_ : 0; + + # first argument is observable name, + # remaining arguments should be pointers to species + my $eval_args = []; + my $ii=1; + while ( $ii < @$args ) + { + push @$eval_args, $args->[$ii]->evaluate( $plist, $level+1 ); + ++$ii; + } + + my $val = 0; + if (@$eval_args) + { # this is a local observable + foreach my $ptr ( @$eval_args ) + { + my ($species_idx,$mol_idx) = split( /\./, $ptr ); + if ( defined $mol_idx ) + { # molecule-scoped observable + unless ( defined $BNGModel::GLOBAL_MODEL ) + { die "Observable->evaluate(): Error! Can't find current Model to evaluate local observable!"; } + + my $sg = $BNGModel::GLOBAL_MODEL->SpeciesList->Array->[$species_idx-1]->SpeciesGraph; + $val += $obs->match( $sg, 0, $mol_idx ); + } + elsif ( $species_idx >= 0 ) + { # complex-scoped (i.e. species-scoped) observable + $val += (defined $obs->Weights->[$species_idx]) ? $obs->Weights->[$species_idx] : 0; + } + else + { die "Observable->evaluate(): Error! Observable argument was not a pointer to a species or a molecule!"; } + + } + } + else + { # global observable + unless ( defined $BNGModel::GLOBAL_MODEL ) + { die "Observable->evaluate(): Error! Can't find current Model to evaluate global observable!"; } + + my $conc = $BNGModel::GLOBAL_MODEL->Concentrations(); + my $slist = $BNGModel::GLOBAL_MODEL->SpeciesList(); + + # make sure oncentrations are initialized + $slist->checkOrInitConcentrations($conc); + # calculate global observables + for ( my $sidx = 1; $sidx < @{$obs->Weights}; ++$sidx ) + { + next unless ( defined $obs->Weights->[$sidx] ); + $val += $obs->Weights->[$sidx] * $conc->[$sidx-1]; + } + } + return $val; +} + + +### +### +### + + +sub toString +{ + my $obs = shift; + my $string = $obs->Type . ' ' . $obs->Name; + foreach my $patt (@{$obs->Patterns}) + { + $string .= ' ' . $patt->toString(); + } + return $string; +} + + +sub toStringSSC +{ + my $obs=shift; + my $string = ''; + foreach my $patt (@{$obs->Patterns}) + { + my ($tempstring, $trash) = $patt->toStringSSC(); + $string .= ' ' . $tempstring; + } + return $string; +} + + +### +### +### + + +sub toCVodeString +{ + my $obs = shift; + my $plist = (@_) ? shift : undef; + + if ( $obs->Type ne 'Function' ) + { + # create linear sum of terms that contribute to the observable + # BE CAREFUL: species indexed starting from 1. + my @terms = (); + for ( my $idx1=1; $idx1 < @{$obs->Weights}; $idx1++ ) + { + my $idx0 = $idx1 - 1; + if ( defined $obs->Weights->[$idx1] and $obs->Weights->[$idx1]!=0 ) + { + my $term; + if ( $obs->Weights->[$idx1] == 1 ) + { $term = "NV_Ith_S(species,$idx0)"; } + else + { $term = $obs->Weights->[$idx1] . "*NV_Ith_S(species,$idx0)"; } + push @terms, $term; + } + } + if ( @terms ) + { return join( ' +', @terms ); } + else + { return "0.0"; } + } + else + { + # handle function type observable! + ( my $param, my $err ) = $plist->lookup( $obs->Name ); + return $param->Expr->toCVodeString( $plist ); + } +} + + +### +### +### + + +sub toMatlabString +{ + my $obs = shift; + my $plist = (@_) ? shift : undef; + + if ( $obs->Type ne 'Function' ) + { + # create linear sum of terms that contribute to the observable + # BE CAREFUL: species indexed starting from 1. + my @terms = (); + for ( my $idx1=1; $idx1 < @{$obs->Weights}; $idx1++ ) + { + if ( defined $obs->Weights->[$idx1] and $obs->Weights->[$idx1]!=0 ) + { + my $term; + if ( $obs->Weights->[$idx1] == 1 ) + { $term = "species($idx1)"; } + else + { $term = $obs->Weights->[$idx1] . "*species($idx1)"; } + push @terms, $term; + } + } + if ( @terms ) + { return join( ' +', @terms ); } + else + { return "0.0"; } + } + else + { + # handle function type observable! + ( my $param, my $err ) = $plist->lookup( $obs->Name ); + return $param->Expr->toMatlabString( $plist ); + } +} + + +### +### +### + + +sub toXML +{ + my $obs = shift @_; + my $indent = shift @_; + my $index = shift @_; + + my $id = "O" . $index; + my $string = $indent . "Name) + { + $string .= " name=\"" . $obs->Name . "\""; + } + # type + if ($obs->Type) + { + $string .= " type=\"" . $obs->Type . "\""; + } + ## output flag (TODO: disable for now) + #if (defined $obs->Output) + #{ + # $string .= " output=\"" . $obs->Output . "\""; + #} + + + # Objects contained + my $indent2= " ".$indent; + my $ostring=$indent2."\n"; + my $ipatt=1; + foreach my $patt (@{$obs->Patterns}) + { + my $indent3 = " ".$indent2; + my $pid = $id."_P".$ipatt; + $ostring .= $patt->toXML($indent3,"Pattern",$pid,""); + ++$ipatt; + } + $ostring .= $indent2 . "\n"; + + # Termination + if ($ostring) + { + $string .= ">\n"; # terminate tag opening + $string .= $ostring; + $string .= $indent."\n"; + } + else + { + $string .= "/>\n"; # short tag termination + } +} + + +### +### +### + + +sub getWeightVector +{ + my $obs = shift; + + my @wv = (); + foreach my $i ( 1..$#{$obs->Weights} ) + { + my $w = $obs->Weights->[$i]; + if ($w) + { + push @wv, $w; + } + else + { + push @wv, 0; + } + } + return @wv; +} + + +### +### +### + + +sub toGroupString +{ + my $obs = shift @_; + my $slist = shift @_; + + my $out = sprintf "%-20s ", $obs->Name; + my $i = -1; + my $first = 1; + my $n_elt = 0; + foreach my $w (@{$obs->Weights}) + { + ++$i; + next unless $w; + ++$n_elt; + if ($first) + { + $first = 0; + } + else + { + $out .= ","; + } + + if ($w==1) + { + $out .= "$i"; + } + else + { + $out .= "$w*$i"; + } + } + + if ($print_match) + { + print $obs->Patterns->[0]->toString(),": "; + my $i=-1; + foreach my $w (@{$obs->Weights}) + { + ++$i; + next unless $w; + my $sstring = $slist->Array->[$i-1]->SpeciesGraph->toString(); + foreach my $nw (1..$w) + { + print "$sstring, "; + } + } + print "\n"; + } + + #printf "Group %s contains %d elements.\n", $obs->Name, $n_elt; + return $out; +} + + +### +### +### + + +# Returns number of nonzero elements in the Group +sub sizeOfGroup +{ + my $obs = shift; + my $n_elt = 0; + foreach my $w (@{$obs->Weights}) + { + next unless $w; + ++$n_elt; + } + return $n_elt; +} + + +### +### +### + + +sub printGroup +{ + my $obs = shift; + my $fh = shift; + my $species = shift; + my $idx_start = (@_) ? shift : 0; + + printf $fh "%s ", $obs->Name; + + my $first=1; + for ( my $ii = $idx_start; $ii < @$species; ++$ii ) + { + my $spec = $species->[$ii]; + my $sp_idx = $spec->Index; + my $weight = $obs->Weights->[$sp_idx]; + next unless $weight; + + if ($first) { $first = 0; } + else { print $fh ","; } + + if ( $weight==1 ) { print $fh $sp_idx; } + else { print $fh "$weight*$sp_idx"; } + } + print $fh "\n"; + return ''; +} + + +### +### +### + + +sub toMathMLString +{ + my $obs = shift; + + my $string = "\n"; + my $n_elt = $obs->sizeOfGroup(); + + $string .= " \n"; + $string .= " \n"; + if ($n_elt<=1) + { + $string .= sprintf " 0 \n"; + } + + my $i=-1; + foreach my $w (@{$obs->Weights}) + { + ++$i; + next unless $w; + if ($w==1) + { + $string .= sprintf " S%d \n", $i; + } + else + { + $string.= " \n"; + $string.= " \n"; + $string.= sprintf " %s \n", $w; + $string.= sprintf " S%d \n", $i; + $string.= " \n"; + } + } + # Include zero entry if no nonzero weights + if ($n_elt==0) + { + $string .= " 0 \n"; + } + + $string .= " \n"; + $string .= "\n"; + + return ($string, ''); +} + + +### +### +### + +1; diff --git a/libvcell/vcell_install/bionetgen/Perl2/Param.pm b/libvcell/vcell_install/bionetgen/Perl2/Param.pm new file mode 100644 index 0000000..e44f951 --- /dev/null +++ b/libvcell/vcell_install/bionetgen/Perl2/Param.pm @@ -0,0 +1,395 @@ +# $Id: Param.pm,v 1.3 2006/09/26 03:36:00 faeder Exp $ + +package Param; + +# pragmas +#use strict; +#use warnings; +no warnings 'redefine'; + +# Perl Modules +use Class::Struct; + +# BNG Modules +use ParamList; +use Expression; + + + +# A "parameter" object is a name associated with an Expression, Function or Observable. +struct Param => +{ + Name => '$', # Parameter name + Expr => 'Expression', # Refers to the expression object + Type => '$', # Parameter type (see below for allowed types) + Ref => '$', # For Observables and Functions: refers to the function or observable object + CVodeRef => '$', # describes the parameter location in a CVode vector + Index => '$', # vector index for network outputs. NOTE: Constant and ConstantExpression type + # are indexed separately from Observable type. Function and Local types not indexed. +}; + + +# This hash describes the allowed parameter types +my %allowedTypes = ( Constant => 1, # A number or an expression involving only numbers + ConstantExpression => 1, # An expression involving at least one other Constant or ConstantExpression + Observable => 1, # A variable defined by the name of an Observable - may take a single argument + Function => 1, # A function call w/ arguments + Local => 1, # local arguments to functions + RRef => 1, # Reactant Reference (not yet implemented) + ); + + +### +### +### + + +# evaluate the expression that this parameter refers to +sub evaluate +{ + my $param = shift @_; + my $args = @_ ? shift @_ : []; + my $plist = @_ ? shift @_ : undef; + my $level = @_ ? shift @_ : 0; + + #print STDERR "eval param name: ", $param->Name ," type: ", $param->Type, "\n"; + if ($param->Type eq 'Constant' or $param->Type eq 'ConstantExpression' ) + { + if ( defined $param->Expr ) + { return $param->Expr->evaluate($plist, $level+1); } + } + elsif ( $param->Type eq 'Function' or $param->Type eq 'Observable' ) + { + if ( defined $param->Ref ) + { return $param->Ref->evaluate($args, $plist, $level+1); } + } + return undef; +} + + +### +### +### + + +sub copyConstant +{ + my $param = shift @_ ; + my $plist = @_ ? shift @_ : undef; + + return undef unless ( $param->Type eq 'Constant' or $param->Type eq 'ConstantExpression' ); + + my $param_copy = Param->new( 'Name' => $param->Name, 'Type' => $param->Type ); + if (defined $param->Expr) + { + my ($expr_copy, $err) = $param->Expr->clone($plist); + if ($err) { print "$err\n"; return undef; } + $param_copy->Expr( $expr_copy ); + } + return $param_copy; +} + + +### +### +### + + +# set the type field of this parameter +sub setType +{ + my $param = shift @_; + my $type = shift @_; + my $ref = @_ ? shift @_ : ''; + + unless ( exists $allowedTypes{$type} ) + { + die "Type $type not recognized in setType"; + } + + $param->Type($type); + if ($ref) { $param->Ref($ref); } + return ''; +} + + +### +### +### + + +# Write the expression that this parameter refers to: +# expand = 0,1 : always write expression +# expand = 2 : write expression, unless constant (just write param name in this case). +sub toString +{ + my $param = shift @_; + my $plist = @_ ? shift @_ : undef; + my $level = @_ ? shift @_ : 0; + my $expand = @_ ? shift @_ : 0; + + if ( $param->Type eq 'Constant' and $expand == 2 ) + { + return $param->Name; + } + else + { + if ( defined $param->Expr ) + { + return $param->Expr->toString($plist, $level, $expand); + } + else + { # TODO: ?? + return ''; + } + } +} + + +### +### +### + + +# Initialize Parameter from XML hash +# ($param, $err) = Param->readXML( \%xml_hash, $plist ) +sub readXML +{ + my ($xml_hash, $plist) = @_; + + # Read expression + my $string = $xml_hash->{'-value'}; + my $expr = Expression->new(); + $expr->setAllowForward(1); + if ( my $err = $expr->readString( \$string, $plist ) ) { return undef, $err; } + $expr->setAllowForward(0); + + # setup parameter + my $param = Param->new( 'Name' => $xml_hash->{'-id'}, + 'Type' => $xml_hash->{'-type'}, + 'Expr' => $expr ); + + # return parameter + return $param, undef; +} + + +### +### +### + + +# Write the parameter to XML +sub toXML +{ + my $param = shift @_; + my $plist = @_ ? shift @_ : undef; + my $level = @_ ? shift @_ : 0; + my $expand = @_ ? shift @_ : 0; + + if ( $param->Type eq 'Constant' and $expand == 2 ) + { + return $param->Name; + } + else + { + if ( $param->Expr ) + { + return $param->Expr->toXML($plist, $level, $expand); + } + else + { + return ''; + } + } +} + + + +### +### +### + + +# write parameter expression as a CVode string +sub toCVodeString +{ + my $param = shift @_; + my $plist = @_ ? shift @_ : undef; + my $level = @_ ? shift @_ : 0; + my $expand = @_ ? shift @_ : 0; + + if ( $param->Type eq 'Constant') + { + return $param->getCVodeName; + } + elsif ( defined $param->Expr ) + { + return $param->Expr->toCVodeString($plist, $level, $expand); + } + else + { + return ''; + } +} + + +### +### +### + + +sub getCVodeName +{ + my $param = shift @_; + + my $type = $param->Type; + my $expr = $param->Expr; + + my $name; + if ( $type eq 'Constant') + { + $name = 'NV_Ith_S(expressions,' . $param->Index .')'; + } + elsif ( $type eq 'ConstantExpression' ) + { + $name = 'NV_Ith_S(expressions,' . $param->Index .')'; + } + elsif ( $type eq 'Observable' ) + { + $name = 'NV_Ith_S(observables,' . $param->Index .')'; + } + elsif ( $type eq 'Function' ) + { + $name = $param->Name; + } + elsif ( $type eq 'Local' ) + { + $name = $param->Name; + } + + return $name; +} + + +### +### +### + + +sub getMatlabName +{ + my $param = shift; + + my $name; + my $offset = 1; + if ( $param->Type eq 'Constant') + { + $name = 'expressions(' . ($param->Index + $offset) .')'; + } + elsif ( $param->Type eq 'ConstantExpression' ) + { + $name = 'expressions(' . ($param->Index + $offset) .')'; + } + elsif ( $param->Type eq 'Observable' ) + { + $name = 'observables(' . ($param->Index + $offset) .')'; + } + elsif ( $type eq 'Function' ) + { + $name = $param->Name; + } + elsif ( $type eq 'Local' ) + { + $name = $param->Name; + } + elsif ( $type eq 'RRef' ) + { + $name = $param->Name; + } + + return $name; +} + + +### +### +### + + +# write the parameter for Matlab output +sub toMatlabString +{ + my $param = shift; + my $plist = (@_) ? shift : undef; + my $level = (@_) ? shift : 0; + my $expand = (@_) ? shift : 0; + + my $offset = 1; + if ( $param->Type eq 'Constant' ) + { + return 'expressions(' . ($param->Index + $offset) . ')'; + } + elsif ( $param->Expr ) + { + return $param->Expr->toMatlabString($plist, $level, $expand); + } + else + { + return ''; + } +} + + + +### +### +### + + +sub toXMLReference +{ + my $param = shift; + my $head = shift; + my $id = shift; + my $plist = (@_) ? shift : ''; + + if ($head eq ''){ $head = 'Reference'; } + my $string="<$head"; + + # Attributes + # id + if ($id ne '') + { + $string.= " id=\"".$param->Name."\""; + } + # name + $string.= " name=\"".$param->Name."\""; + # type + $string.= " type=\"".$param->Type."\""; + + $string.= "/>\n"; + + return ($string); +} + + +### +### +### + + +sub toMathMLString +{ + my $param = shift; + my $plist = (@_) ? shift : ''; + my $indent = (@_) ? shift : ''; + + if ($param->Expr) + { + return($param->Expr->toMathMLString($plist,$indent)); + } + return (''); +} + +1; diff --git a/libvcell/vcell_install/bionetgen/Perl2/ParamList.pm b/libvcell/vcell_install/bionetgen/Perl2/ParamList.pm new file mode 100644 index 0000000..e8e90f9 --- /dev/null +++ b/libvcell/vcell_install/bionetgen/Perl2/ParamList.pm @@ -0,0 +1,1200 @@ +# $Id: ParamList.pm,v 1.11 2007/08/24 15:10:13 faeder Exp $ + +package ParamList; + +# pragmas +#use strict; +#use warnings; +no warnings 'redefine'; + +# Perl Modules +use Class::Struct; + +# XML Modules +use XMLReader; + +# BNG Modules +use Param; +use Expression; +use BNGUtils("isReal","send_warning"); + + + +# Members +struct ParamList => +{ + Parent => 'ParamList', + Array => '@', + Hash => '%', + Unchecked => '@' +}; + + +### +### +### + + + +sub copyConstant +{ + my $plist = shift @_; + + my $plist_copy = ParamList::new(); + foreach my $param ( @{$plist->Array} ) + { + next unless ($param->Type eq 'Constant' or $param->Type eq 'ConstantExpression' ); + my $param_copy = $param->copyConstant( $plist ); + $plist_copy->add( $param_copy ); + } + + # check and sort paramlist + if ( my $err = $plist_copy->check() ) { print "complain about parameter check\n"; return undef; } + if ( my $err = $plist_copy->sort() ) { print "complain about parameter sort\n"; return undef; } + + return $plist_copy; +} + + + +### +### +### + + + +sub getNumParams +{ + my $plist = shift; + return scalar @{$plist->Array}; +} + +sub size +{ + my $plist = shift; + return scalar @{$plist->Array}; +} + + +### +### +### + + + +# Lookup a parameter by name. +# Returns reference to parameter, if found. +# Otherwise returns undefined. +# +# ($param, $err) = $plist->lookup($name); +sub lookup +{ + my $plist = shift @_; + my $name = shift @_; + + my $param; + if ( exists $plist->Hash->{$name} ) + { + return $plist->Hash->{$name}, ""; + } + elsif ( defined $plist->Parent ) + { + return $plist->Parent->lookup($name), ""; + } + else + { + return undef, "Parameter $name not defined"; + } +} + + +### +### +### + + +sub getChildList +{ + my $plist = shift; + + my $child = ParamList::new(); + $child->Parent( $plist ); + + return $child; +} + + +### +### +### + + + + +# Find an un-used name in the parameter list +# that begins with "basename". +# Don't put the name in the list yet! +sub getName +{ + my $plist = shift; + my $basename = (@_) ? shift : "k"; + + my $name; + # Find unused name + my $index = 1; + while (1) + { + my ( $param, $err ) = $plist->lookup( "${basename}_${index}" ); + last unless $param; + ++$index; + } + $name = "${basename}_${index}"; + return $name; +} + + + +### +### +### + + + +sub evaluate +{ + my $plist = shift @_; + my $name = shift @_; + my $args = @_ ? shift @_ : []; + my $level = @_ ? shift @_ : 0; + + my ($param,$err) = $plist->lookup($name); + if (defined $param) + { + # evaluate the parameter and return value + return $param->evaluate($args, $plist, $level + 1); + } + elsif ( isReal($name) ) + { + # in a few cases, a simple number may appear where a parameter name is expected + # (e.g. Concentration). In these cases, just return the value. + return $name; + } + else + { + print "$name is not a valid number or parameter."; + return undef; + } +} + + + +### +### +### + + + +# parse parameter from a BNGL string +sub readString +{ + my $plist = shift @_; + my $string = shift @_; + my $allow_undefined = @_ ? shift @_ : 0; + + my $sptr = \$string; + my ($name, $val); + + # Remove leading whitespace + $$sptr =~ s/^\s*//; + + # Remove leading numeric index, if any + $$sptr =~ s/^\d+\s+//; # Can't deprecate this because indices used in NET files + + # Remove leading label, if any + if ( $$sptr =~ s/^(\w+)\s*:\s+// ) + { + # Check label for leading number + my $label = $1; + if ($label =~ /^\d/) { return "Syntax error (label begins with a number) at '$label'"; } + } + + # Check name for leading number + my $sptr_left = $$sptr; + unless ( $sptr_left =~ s/^([A-Za-z_]\w*)// ) + { + return "Syntax error (parameter name begins with a number) at '$$sptr'"; + } + + # Convert non assignment format to assignment + unless ( $$sptr =~ /^\w+\s*=/ ) + { + unless ( $$sptr =~ s/^(\w+)\s*(.+)/$1=$2/ ) + { + return "Invalid parameter declaration $$sptr: format is [index] name[=]Expression"; + } + } + + # Read expression + my $expr = Expression->new(); + $expr->setAllowForward(1); + if ( my $err = $expr->readString($sptr,$plist) ) { return $err; } + + # string should be empty now. + if ($$sptr) { return "Syntax error (invalid trailing characters) at $$sptr"; } + $expr->setAllowForward(0); + + return ''; +} + + +### +### +### + + +# parse parameters from XML file +sub readXML +{ + my $plist = shift @_; + my $xml = shift @_; + my $allow_overwrite = @_ ? shift @_ : 0; + my $verbose = @_ ? shift @_ : 0; + + # error message + my $err; + # counters + my $n_pars_new = 0; + my $n_pars_redef = 0; + + my $param_array = $xml->getParameters(); + foreach my $param_hash ( @$param_array ) + { + (my $param, $err) = Parameter->readXML($param_hash, $plist); + if ($err) { return $err; } + + # lookup parameter name + (my $old_param, $err) = $plist->lookup($param->Name); + if ($err) { return $err; } + + # add parameter to Plist + if ( defined $old_param and defined $old_param->Expr ) + { # if a parameter with this name is already defined.. + if ($allow_overwrite) + { # ..copy new param definition over old_param + %$old_param = %$param; + undef %$param; + $param = $old_param; + ++$n_pars_redef; + } + else + { # redefining parameters is not allowed + $err = "Parameter->readXML: attempt to redefine parameter $name is not allowed"; + return $err; + } + } + else + { + # add to plist array, unless type is Local or RRef + unless ( $param->Type eq 'Local' or $param->Type eq 'RRef' ) + { # add param to Plist Array + push @{$plist->Array}, $param; + # add param to unchecked list + push @{$plist->Unchecked}, $param; + } + # add param to Plist hash + $plist->Hash->{ $param->Name } = $param; + # increment counter + ++$n_pars_new; + } + } + + if ($verbose) + { # tell user how many parameters were defined or redefined + print sprintf( "Parameter->readXML: read %d new parameters and redefined %d parameters.\n", $n_pars_new, $n_pars_redef ); + } + + return undef; +} + + + +### +### +### + + + +# add parameter object to list, or overwrite exisitng parameter +sub add +{ + use strict; + use warnings; + + my $plist = shift @_; + my $param = shift @_; + my $no_overwrite = @_ ? shift @_ : 0; + my $global = @_ ? shift @_ : 0; + + #printf "ParamList->add( %s, %d, %d )\n", $param->Name, $no_overwrite, $global; + + if ($global) + { # try to add to parent + if ( defined $plist->Parent ) + { return $plist->Parent->add( $param, $no_overwrite, $global ); } + } + + # Find existing parameter + (my $old_param) = $plist->lookup( $param->Name ); + + # Is this a new parameter definition or a redefinition? + if ( defined $old_param ) + { # overwriting exisitng parameter! + if ( $no_overwrite ) + { return sprintf "Redefining existing parameter '%s' is not permitted", $param->Name; } + + # check if new param has type Local or RRef + if ( $param->Type eq 'Local' or $param->Type eq 'RRef' ) + { + return sprintf( "Redefining non-local parameter '%s' as a local parameter is not permitted", + $param->Name ); + } + + # find old parameter in array + for ( my $idx = 0; $idx < @{$plist->Array}; ++$idx ) + { + my $old_param = $plist->Array->[$idx]; + if( $old_param->Name eq $param->Name ) + { # replace old parameter in array with new parameter + $plist->Array->[$idx] = $param; + # add this to list of parameters to check + push @{$plist->Unchecked}, $param; + # exit loop + last; + } + } + } + else + { # this is a new parameter. + # add to array unless the type is local + unless ( $param->Type eq 'Local' or $param->Type eq 'RRef' ) + { + push @{$plist->Array}, $param; + push @{$plist->Unchecked}, $param; + } + } + + # always add new parameter to lookup table + $plist->Hash->{ $param->Name } = $param; + # all done + return undef; +} + + +# ParamList->set( name, expression ) creates a parameter object from a name and an expression (or reference) +# and then adds the parameter to the list. By default, allows previously defined variable to be overwritten. +# Use $no_overwrite=1 to prevent this. +sub set +{ + my $plist = shift @_; + my $name = shift @_; + my $rhs = @_ ? shift @_ : ''; # this is the expression! + my $no_overwrite = @_ ? shift @_ : 0; + my $type = @_ ? shift @_ : ''; # Overrides derived type of rhs + my $ref = @_ ? shift @_ : ''; # Reference to Function or Observable + my $global = @_ ? shift @_ : 0; # add parameter to top plist + + if ($global) + { # find top plist + while (defined $plist->Parent) + { + $plist = $plist->Parent; + } + } + + # Find existing parameter + my ($param,$err)= $plist->lookup($name); + # or add new parameter to array + unless (defined $param) + { + #print "Adding parameter $name\n"; + $param = Param->new( Name=>$name ); + # add to array, unless Local or RRef + unless ( $type eq 'Local' or $type eq 'RRef' ) + { push @{$plist->Array}, $param; } + # add to hash + $plist->Hash->{$name} = $param; + # Add parameter to list of parameters to be checked + unless ( $type eq 'Local' or $type eq 'RRef' ) + { push @{$plist->Unchecked}, $param; } + # Return leaving param unset if no rhs +# if ($rhs eq '') +# { +# return ''; +# } + } + + # Return leaving param unset if no rhs + if ($rhs eq '') + { + return ''; + } + +# if ($param->Expr ne '') + if (defined $param->Expr) + { + if ($no_overwrite) + { return "Changing value of previously defined variable '$name' is not allowed"; } + else + { send_warning( "Changing value of previously defined variable '$name'" ); } + } + + # Handle scalar (string) argument (probably from setParameter) + if ( ref \$rhs eq 'SCALAR' ) + { + my $expr = Expression->new( Type=>'NUM', Arglist=>[$rhs] ); + $rhs = $expr; + } + + # Set Param->Expression + $param->Expr($rhs); + + # Set Param->Type + if ($type ne '') + { + $param->setType($type); + # Set reference + if ($ref) + { $param->Ref($ref); } + elsif ( $type eq 'Function' ) + { + # create a function out of the RHS expression + my $fun = Function->new(); + $fun->Name($param->Name); + $fun->Expr($param->Expr); + # look for variables with expression + my $vhash = $param->Expr->getVariables($plist); + # find local variables and assign as function arguments + my @args = keys %{$vhash->{Local}}; + $fun->Args([@args]); + # finally, point param Ref field to this function + $param->Ref($fun); + } + } + elsif ($rhs->Type eq 'NUM') + { + $param->setType('Constant'); + } + else + { + # Get hash of variables reference in Expr + my $vhash = $param->Expr->getVariables($plist); + # If expression has undefined parameter types make it a 'Function' type to be safe + if ( exists $vhash->{'Observable'} || exists $vhash->{'Function'} || exists $vhash->{'UNDEF'} ) + { + $param->setType('Function'); + my $fun= Function->new(); + $fun->Name($param->Name); + $fun->Expr($param->Expr); + my @args = keys %{$vhash->{Local}}; + $fun->Args([@args]); + $param->Ref($fun); + } + elsif ( $vhash->{'Constant'} or $vhash->{'ConstantExpression'} ) + { + $param->setType('ConstantExpression'); + } + else + { + # Expression contains only number arguments + $param->setType('Constant'); + } + } + + return ''; +} + + + +### +### +### + + + +sub toString +{ + my $plist = shift; + + my $out = ''; + foreach my $param ( @{$plist->Array} ) + { + $out .= sprintf "Parameter %s=%s\n", $param->Name, $param->toString($plist); + } + return $out; +} + + + +### +### +### + + + +# This serves an input file in SSC which contains information corresponding to our parameters block in BNG +sub writeSSCcfg +{ + my $plist = shift; + + my $out = "# begin parameters\n"; + my $iparam = 1; + foreach my $param ( @{$plist->Array} ) + { + my $type = $param->Type; + next unless ( $type =~ /^Constant/ ); + $out .= " " . $param->Name . " = "; + $out .= $param->evaluate([],$plist) . "\n"; + ++$iparam; + } + $out .= "# end parameters\n"; + + return $out; +} + + + +### +### +### + + + +sub writeBNGL +{ + my $plist = shift @_; + my $user_params = @_ ? shift @_ : { 'pretty_formatting'=>0, 'evaluate_expressions'=>0 }; + + # find longest parameter name + my $max_length = 0; + foreach my $param (@{$plist->Array}) + { + $max_length = ($max_length >= length $param->Name) ? $max_length : length $param->Name; + } + + # now write parameter strings + my $iparam = 1; + my $out .= "begin parameters\n"; + foreach my $param (@{$plist->Array}) + { + next unless ( $param->Type =~ /^Constant/ ); + + if ( $user_params->{'pretty_formatting'} ) + { # no parameter index + $out .= ' '; + } + else + { # include index + $out .= sprintf "%5d ", $iparam; + } + + $out .= sprintf "%-${max_length}s ", $param->Name; + + if ( $user_params->{'evaluate_expressions'} ) + { # evaluate expression (return a number) + $out .= $param->evaluate([], $plist); + } + else + { # write parameter expression as a string + $out .= $param->toString($plist); + + } + + if ( $user_params->{'pretty_formatting'} ) + { # no parameter type + $out .= "\n"; + } + else + { # include parameter type + $out .= " # " . $param->Type . "\n"; + } + + ++$iparam; + } + $out .= "end parameters\n"; + + return $out; +} + + + +### +### +### + + + +sub writeFunctions +{ + my $plist = shift @_; + my $user_params = @_ ? shift @_ : { 'pretty_formatting'=>0 }; + + my $max_length = 0; + if ( $user_params->{pretty_formatting} ) + { + # find longest function name + foreach my $param ( @{$plist->Array} ) + { + my $type= $param->Type; + next unless ( $param->Type eq 'Function' ); + + my $string = $param->Ref->toString( $plist, 1); + $string =~ /\=/g; + $max_length = ( pos $string > $max_length ) ? pos $string : $max_length; + } + } + + my $out = "begin functions\n"; + my $iparam=1; + foreach my $param ( @{$plist->Array} ) + { + my $type= $param->Type; + next unless ( $param->Type eq 'Function' ); + + if ( $user_params->{'pretty_formatting'} ) + { # no function index + $out .= ' ' . $param->Ref->toString( $plist, 1, $max_length) . "\n"; + } + else + { # include function index + next if ( $param->Ref->checkLocalDependency($plist) ); + $out .= sprintf "%5d", $iparam; + $out .= ' ' . $param->Ref->toString( $plist, 0) . "\n"; + } + ++$iparam; + } + $out.="end functions\n"; + + # Don't output null block + if ( $iparam==1 ){ $out = ''; } + + return $out; +} + + + +### +### +### + + + +sub copyFunctions +{ + my $plist = shift; + + my $fcn_copies = []; + foreach my $param ( @{$plist->Array} ) + { + if ( $param->Type eq 'Function' ) + { + # arguments are: parameter list, level, same_name + my ($fcn_copy,$err) = $param->Ref->clone( $plist, 0, 1 ); + push @$fcn_copies, $fcn_copy; + } + } + + return $fcn_copies; +} + + + +### +### +### + + + +# Delete a parameter from the ParamList by name +sub deleteLocal +{ + my $plist = shift; + my $pname = shift; + + # Find parameter + my ($param,$err) = $plist->lookup($pname); + if ($err) { return($err); } + + # check that this is a local type + if ($param->Type ne 'Local') { return "Parameter $pname is not a local parameter"; } + + # remove param from lookup hash + delete $plist->Hash->{$pname}; + + # undefine parameter object + %{$param} = (); + $param = undef; + + return ''; +} + + + +### +### +### + + + +# Delete a parameter from the ParamList by name +sub deleteParam +{ + my $plist = shift; + my $pname = shift; + + # Find parameter + my ($param,$err) = $plist->lookup($pname); + if ($err) { return($err); } + + # remove param from lookup hash + delete $plist->Hash->{$pname}; + + # remove param from array (expensive) + my $index = @{$plist->Array}; + while ($index > 1) + { + --$index; + if ( $param == $plist->Array->[$index] ) + { + splice( @{$plist->Array}, $index, 1); + last; + } + } + + # remove param from unchecked (expensive) + $index = @{$plist->Unchecked}; + while ($index > 1) + { + --$index; + if ( $param == $plist->Unchecked->[$index] ) + { + splice( @{$plist->Unchecked}, $index, 1); + } + } + + # undefine parameter object + undef %{$param}; + $param = undef; + + return ''; +} + + + +### +### +### + + + +# check the parameter list undefined or cyclic dependency +sub check +{ + my $plist = shift; + my $err = ''; + + foreach my $param (@{$plist->Unchecked}) + { + # Check that variable has defined value + #printf "Checking if parameter %s is defined.\n", $param->Name; + unless ( $param->Type ) + { + $err= sprintf "Parameter '%s' is referenced but not defined", $param->Name; + last; + } + } + if ($err) { return ($err) }; + + foreach my $param ( @{$plist->Unchecked} ) + { + #printf "Checking parameter %s for cycles.\n", $param->Name; + # Check that variable doesn't have cylic dependency + (my $dep, $err) = ($param->Expr->depends( $plist, $param->Name )); + if ($dep) + { + $err= sprintf "Parameter %s has a dependency cycle %s", $param->Name, $param->Name.'->'.$dep; + last; + } + } + + # Reset list of Unchecked parameters if all parameters passed checks. + unless ( $err ) + { + undef @{$plist->Unchecked}; + #printf "Unchecked=%d\n", scalar(@{$plist->Unchecked}); + } + return ($err); +} + + + +### +### +### + + + +# sort the Array of parameters by dependency +{ + my $plist; + my $err; + sub sort + { + $plist = shift; + $err = ''; + + $plist->Array( [sort by_depends @{$plist->Array}] ); + return($err); + } + + sub by_depends + { + (my $dep_a, $err) = $a->Expr->depends( $plist, $b->Name ); + if ($err) + { #printf "$err %s %s\n", $a->Name, $b->Name; + return(0); + } + + if ($dep_a) + { #printf "%s depends on %s\n", $a->Name, $b->Name; + return(1); + } + + (my $dep_b, $err) = $b->Expr->depends( $plist, $a->Name ); + if ($err) + { + return(0); + } + + if ($dep_b) + { #printf "%s depends on %s\n", $b->Name, $a->Name; + return(-1); + } + + #printf "%s and %s are independent\n", $a->Name, $b->Name; + return(0); + } +} + + + +### +### +### + + + +# Assign indices to Parameters. BNG doesn't use this, but it's helpful +# for writing network models in vector form. +# NOTE: Constant and ConstantExpression types are indexed separately +# from Observable types. Function and Local types not indexed. +sub indexParams +{ + my $plist = shift; + my $err; + + # check parameter list for undefined and cyclic dependency + ($err) = $plist->check(); + if ( $err ) { return ( undef, $err) }; + + # sort paramlist by dependency! + ($err) = $plist->sort(); + if ( $err ) { return ( undef, $err) }; + + # index parameter types + my $n_expressions = 0; + my $n_observables = 0; + + # loop through parameters and generate + foreach my $param ( @{ $plist->Array } ) + { + my $type = $param->Type; + my $expr = $param->Expr; + if ( $type eq 'Constant') + { + $param->Index( $n_expressions ); + $param->CVodeRef( "NV_Ith_S(expressions,$n_expressions)" ); + ++$n_expressions; + } + elsif ( $type eq 'ConstantExpression' ) + { + $param->Index( $n_expressions ); + $param->CVodeRef( "NV_Ith_S(expressions,$n_expressions)" ); + ++$n_expressions; + } + elsif ( $type eq 'Observable' ) + { + $param->Index( $n_observables ); + $param->CVodeRef( "NV_Ith_S(observables,$n_observables)" ); + ++$n_observables; + } + else + { + $param->Index( undef ); + $param->CVodeRef( '' ); + } + } + + return ($err); +} + + + +### +### +### + + + +# return a string with CVode expression defintions. +# Call "indexParams" before this! +sub getCVodeExpressionDefs +{ + my $plist = shift; + + # !!! Assume that parameter list is checked and sorted by dependency !!! + + # expression definition string + my $expr_defs = ''; + # to hold errors.. + my $err; + # count constants + my $n_constants = 0; + # size of the indent + my $indent = ' '; + + # loop through parameters and generate + foreach my $param ( @{ $plist->Array } ) + { + # get type + my $type = $param->Type; + if ( $type eq 'Constant') + { + # constants are defined in terms of the input parameters + $expr_defs .= $indent . $param->getCVodeName() . " = parameters[$n_constants];\n"; + ++$n_constants; + } + elsif ( $type eq 'ConstantExpression' ) + { + # constant expressions are defined in terms of other expressions + $expr_defs .= $indent . $param->getCVodeName() . " = " . $param->Expr->toCVodeString( $plist ) . ";\n"; + } + } + + return ($expr_defs, $err); +} + + + +### +### +### + + + +# return a string with Matlab expression defintions. +# Call "indexParams" before this! +sub getMatlabExpressionDefs +{ + my $plist = shift; + + # !!! Assume that parameter list is checked and sorted by dependency !!! + + # expression definition string + my $expr_defs = ''; + # to hold errors.. + my $err; + # count constants + my $n_constants = 0; + # size of the indent + my $indent = ' '; + # matlab array index offset + my $offset = 1; + + # loop through parameters and generate + foreach my $param ( @{ $plist->Array } ) + { + # get type + my $type = $param->Type; + if ( $type eq 'Constant') + { + # constants are defined in terms of the input parameters + $expr_defs .= $indent . $param->getMatlabName() . " = parameters(" . ($n_constants + $offset) . ");\n"; + ++$n_constants; + } + elsif ( $type eq 'ConstantExpression' ) + { + # constant expressions are defined in terms of other expressions + $expr_defs .= $indent . $param->getMatlabName() . " = " . $param->Expr->toMatlabString( $plist ) . ";\n"; + } + } + + return ($expr_defs, $err); +} + + + +### +### +### + + + +# return a string with CVode observable defintions. +sub getCVodeObservableDefs +{ + my $plist = shift; + + # expression definition string + my $obsrv_defs = ''; + # to hold errors.. + my $err; + # size of the indent + my $indent = ' '; + + # loop through parameters and generate observable definitions + foreach my $param ( @{ $plist->Array } ) + { + if ( $param->Type eq 'Observable') + { + my $obsrv = $param->Ref; + # constants are defined in terms of the input parameters + $obsrv_defs .= $indent . $param->getCVodeName() . " = " . $obsrv->toCVodeString($plist) . ";\n"; + } + } + + return ($obsrv_defs, $err); +} + + + +### +### +### + + + +# return a string with Matlab observable defintions. +sub getMatlabObservableDefs +{ + my $plist = shift; + + # expression definition string + my $obsrv_defs = ''; + # to hold errors.. + my $err; + # size of the indent + my $indent = ' '; + + # loop through parameters and generate observable definitions + foreach my $param ( @{ $plist->Array } ) + { + if ( $param->Type eq 'Observable') + { + my $obsrv = $param->Ref; + # constants are defined in terms of the input parameters + $obsrv_defs .= $indent . $param->getMatlabName() . " = " . $obsrv->toMatlabString($plist) . ";\n"; + } + } + + return ($obsrv_defs, $err); +} + + + +### +### +### + + + +# get names of constnat parameters and default values in a string that define +# matlab arrays +sub getMatlabConstantNames +{ + my $plist = shift @_; + + my $err; + + my @default_values = (); + my @constant_names = (); + + # loop through parameters and generate names and values for constants + foreach my $param ( @{ $plist->Array } ) + { + if ( $param->Type eq 'Constant') + { + push @default_values, $param->evaluate([], $plist); + push @constant_names, "'" . $param->Name . "'"; + } + } + + return ( join(', ', @constant_names), join(', ', @default_values), $err ); +} + + + +### +### +### + + + +# get names of observables for matlab +sub getMatlabObservableNames +{ + my $plist = shift; + + my $err; + + my @observable_names = (); + # loop through params and find observables + foreach my $param ( @{ $plist->Array } ) + { + if ( $param->Type eq 'Observable') + { + push @observable_names, "'" . $param->Name . "'"; + } + } + + return ( join(', ', @observable_names), $err ); +} + + + +### +### +### + + + +# count the number of parameters with a type +sub countType +{ + my $plist = shift; + my $type = shift; + + my $count = 0; + foreach my $param ( @{$plist->Array} ) + { + ++$count if ( $param->Type eq $type ); + } + return $count; +} + + + +### +### +### + +1; diff --git a/libvcell/vcell_install/bionetgen/Perl2/Population.pm b/libvcell/vcell_install/bionetgen/Perl2/Population.pm new file mode 100644 index 0000000..c29eedd --- /dev/null +++ b/libvcell/vcell_install/bionetgen/Perl2/Population.pm @@ -0,0 +1,98 @@ +package Population; +# an object for managing population species: +# maps a species' graph to its representative population molecule + +# pragmas +use strict; +use warnings; +no warnings 'redefine'; + +# Perl Modules +use Class::Struct; +use FindBin; +use lib $FindBin::Bin; + +# BNG Modules +use BNGUtils; +use Molecule; +use SpeciesGraph; +use Species; +use RxnRule; +use BNGModel; + + + + +struct Population => +{ + SpeciesGraph => 'SpeciesGraph', + Population => 'SpeciesGraph', + MappingRule => 'RxnRule' +}; + +## +## + +sub newPopulation +{ + # get input arguments + my ($string, $model, $index) = @_; + + # define return arguments + my $err = undef; + my $pop = undef; + + # parse population mapping rule + my $rr; + ($err, $rr) = RxnRule::newPopulationMappingRule( $string, $model ); + if ($err) { return $err, $pop; } + + unless ( defined $rr->Name ) + { # give map rule a name + $rr->Name( '_MapRule' . $index ); + } + + # define population + $pop = Population->new( SpeciesGraph=>$rr->Reactants->[0], Population=>$rr->Products->[0], MappingRule=>$rr ); + + # create species object to go along with this population + my $spec = Species->new( SpeciesGraph=>$pop->SpeciesGraph, Concentration=>0, Index=>$index, RulesApplied=>0, ObservablesApplied=>0 ); + $pop->SpeciesGraph->Species($spec); + + # return normally + return ($err, $pop); +}; + + +sub toXML +{ + my $pop = shift; + my $plist = shift; + my $indent = (@_) ? shift : ''; + my $indent2 = " " . $indent; + my $indent3 = " " . $indent2; + my $pmindex = shift; + my $pmid = shift; + my $sid = $pmid . "_SS1"; + my $pid = $pmid . "_PS1"; + my $rid = $pmid . "_RL1"; + + # get species (structured species) + my $popstring .= $indent2 . "\n"; + $popstring .= $pop->SpeciesGraph->toXML( $indent3, "Species", $sid, "" ); + $popstring .= $indent2 . "\n"; + + # get population count (population species) + $popstring .= $indent2 . "\n"; + $popstring .= $pop->Population->toXML( $indent3, "Species", $pid, "" ); + $popstring .= $indent2 . "\n"; + + # get rate law + $popstring .= $pop->MappingRule->RateLaw->toXML( $indent2, $rid, $plist ); + + return $popstring; +} + + + +1; diff --git a/libvcell/vcell_install/bionetgen/Perl2/PopulationList.pm b/libvcell/vcell_install/bionetgen/Perl2/PopulationList.pm new file mode 100644 index 0000000..621611d --- /dev/null +++ b/libvcell/vcell_install/bionetgen/Perl2/PopulationList.pm @@ -0,0 +1,120 @@ +package PopulationList; +# a class for managing a list of populations + +# pragmas +use strict; +use warnings; +no warnings 'redefine'; + +# Perl Modules +use Class::Struct; +use FindBin; +use lib $FindBin::Bin; + +# BNG Modules +use BNGUtils; +use Molecule; +use SpeciesGraph; +use RxnRule; +use BNGModel; +use Population; + + + + +struct PopulationList => +{ + List => '@', + MapSpecies => '%', # map species labels to population labels (mostly for checking if species is already mapped) + MapPopulations => '%' # map population labels to species labels (mostly for checking if population is already target of map) +}; + + +# read string that defines a population mapping and add population to list +sub readString +{ + # get input arguments + my $pop_list = shift; + my $string = shift; + my $model = shift; + + # define return arguments + my $err; + my $pop; + + # parse string and get population object + ($err,$pop) = Population::newPopulation( $string, $model, scalar @{$pop_list->List} ); + if ($err) { return $err; } + + + # make sure population mapping is unique! + my $species_label = $pop->SpeciesGraph->StringExact; + my $population_label = $pop->Population->StringExact; + + + # check if this species was already mapped to a population + if ( exists $pop_list->MapSpecies->{$species_label} ) + { + $err = "Species with label '$species_label' is already mapped to a population object"; + return $err; + } + + # check if some other species is mapped to this population + if ( exists $pop_list->MapPopulations->{$population_label} ) + { + $err = "Population with label '$population_label' is already the target of a mapping"; + return $err; + } + + # add this population to the list + push @{$pop_list->List}, $pop; + $pop_list->MapSpecies->{$species_label} = $population_label; + $pop_list->MapPopulations->{$population_label} = $species_label; + + # return normally + return $err; +} + + + +### +### +### + + + +sub getNumPopulations +{ + my $pop_list = shift; + return scalar @{$pop_list->List}; +} + + + +sub toXML +{ + my $pl = shift; + my $model = shift; + my $plist = (@_) ? shift : ''; + my $indent = (@_) ? shift : ''; + my $indent2 = " " . $indent; + my $pmindex = 1; + my $pmid = ""; + + my $mapstring .= $indent . "\n"; + foreach my $popmap ( @{$model->PopulationList->List} ) + { + $pmid = "PM" . $pmindex; + $mapstring .= $indent2 . "\n"; + $mapstring .= $popmap->toXML( $plist, $indent2, $pmindex, $pmid ); + ++$pmindex; + $mapstring .= $indent2 . "\n"; + } + $mapstring .= $indent . "\n"; + + return $mapstring; +} + + + +1; \ No newline at end of file diff --git a/libvcell/vcell_install/bionetgen/Perl2/RateLaw.pm b/libvcell/vcell_install/bionetgen/Perl2/RateLaw.pm new file mode 100644 index 0000000..0e1bc9d --- /dev/null +++ b/libvcell/vcell_install/bionetgen/Perl2/RateLaw.pm @@ -0,0 +1,1395 @@ +package RateLaw; + +# pragmas +use strict; +use warnings; + +# Perl Modules +use Class::Struct; +use FindBin; +use lib $FindBin::Bin; +use Scalar::Util ("looks_like_number"); +use Carp qw(cluck); + +# BNG Modules +use BNGUtils; +use SpeciesGraph; +use Expression; + +# Class definition +struct RateLaw => +{ + Type => '$', # Ele, Sat, Hill, MM, Arrhenius, Function, FunctionProduct + Constants => '@', # If function, first constant is the function name and the following are local args + Factor => '$', # Statistical or Multiplicity factor + TotalRate => '$', # If true, this ratelaw specifies the Total reaction rate. + # If false (default), the ratelaw specifies a Per Site reaction rate. + LocalRatelawsHash => '%', # A map from locally-evaluated ratelaw "fingerprints" and instances of those ratelaws. + # This allows for efficient reuse of local ratelaws. +}; + + + +# track total number of ratelaws +my $n_RateLaw = 0; + + + +### +### +### + + +sub copy +{ + my $rl = shift @_; + my $rl_copy = RateLaw->new( Type=>$rl->Type, Constants=>[@{$rl->Constants}], Factor=>$rl->Factor, TotalRate=>$rl->TotalRate ); + #%{$rl_copy->LocalRatelawsHash} = %{$rl_copy->LocalRatelawsHash}; + #%{$rl_copy->LocalRatelawsHash} = %{$rl_copy->LocalRatelawsHash}; + ++$n_RateLaw; + return $rl_copy; +} + + + +### +### +### + + +# Two basic formats are possible +# [stat_factor*]rate_constant_forward +# or +# [stat_factor*]rate_law_type(rate_constant1,...,rate_constantN) + +# create a new ratelaw from a BNGL string +sub newRateLaw +{ + my $strptr = shift @_; + my $model = shift @_; + my $totalRate = @_ ? shift @_ : 0; + my $reactants = @_ ? shift @_ : undef; + my $basename = @_ ? shift @_ : "_rateLaw"; + + my $string_left = $$strptr; + my $name; + my $rate_law_type; + my $rate_fac = 1; + my @rate_constants = (); + my $param; + my $err; + + # if totalRate, we need to force expression into a function, + # even if it's a constant function. + my $force_fcn = $totalRate ? 1 : 0; + + # Determine type of RateLaw + if ( $string_left =~ s/^(Sat|MM|Hill)\(// ) + { # TODO: convert Sat, MM and Hill into regular functions? + $rate_law_type = $1; + + if ($totalRate) { return undef, "TotalRate keyword is not compatible with $rate_law_type type RateLaw."; } + # Validate remaining rate constants + my $found_end = 0; + while ( $string_left =~ s/^(\w+)\s*// ) + { + my $rc = $1; + ($param, $err) = $model->ParamList->lookup($rc); + if ($err) { return '', $err; } + push @rate_constants, $rc; + next if ($string_left =~ s/^,\s*//); + if ($string_left =~ s/\)//) { $found_end=1; } + } + unless ($found_end) { return undef, "RateLaw not terminated at $string_left"; } + } + elsif ( $string_left =~ s/^FunctionProduct\(\s*// ) + { + # Ratelaw is defined by a product of two local functions: + # each local function in the product may depend on (at most) one reactant. + + $string_left =~ s/^"([^"]+)"\s*,\s*//; + my $expr_string_1 = $1; + + $string_left =~ s/^"([^"]+)"\s*\)\s*//; + my $expr_string_2 = $1; + + # Read function 1 + my $expr1 = Expression->new(); + $err = $expr1->readString( \$expr_string_1, $model->ParamList ); + if ($err) { return '', $err } + # get name for ratelaw + my $name1 = $expr1->getName( $model->ParamList, "_localFuncL", $force_fcn ); + # retreive param with this name + (my $param1, $err) = $model->ParamList->lookup($name1); + if ($err) { return undef, $err; } + + # Read function 2 + my $expr2 = Expression->new(); + my $err = $expr2->readString( \$expr_string_2, $model->ParamList ); + if ($err) { return '', $err } + # get name for ratelaw + my $name2 = $expr2->getName( $model->ParamList, "_localFuncR", $force_fcn ); + # retreive param with this name + (my $param2, $err) = $model->ParamList->lookup($name2); + if ($err) { return undef, $err; } + + # set ratelaw type + $rate_law_type = "FunctionProduct"; + # constants are: fcn name 1, fcn name 2, array of fcn1 args, array of fcn2 args + my $args1 = ($param1->Type eq "Function") ? [@{$param1->Ref->Args}] : []; + my $args2 = ($param1->Type eq "Function") ? [@{$param2->Ref->Args}] : []; + + push @rate_constants, ($name1, $name2, $args1, $args2 ); + } + elsif ( $string_left =~ s/^Arrhenius\(\s*// ) + { + if ($totalRate) { return undef, "TotalRate keyword is not compatible with Arrhenius type RateLaw."; } + + $rate_law_type = "Arrhenius"; + + # extract phi term + my $phi_expr = Expression->new(); + $err = $phi_expr->readString( \$string_left, $model->ParamList, "," ); + if ($err) { return undef, "Unable to parse Arrhenius ratelaw (expecting phi string): $err"; } + my $phi_name = $phi_expr->getName( $model->ParamList, "_Aphi_" ); + (my $phi_param, $err) = $model->ParamList->lookup($phi_name); + if ($err) { return undef, $err; } + + # remove separating comma and quotes + $string_left =~ s/^\s*,\s*//; + + # extract activation energy expression + my $actE_expr = Expression->new(); + $err = $actE_expr->readString( \$string_left, $model->ParamList ); + if ($err) { return undef, "Unable to parse Arrhenius ratelaw (expecting activation energy string): $err"; } + my $actE_name = $actE_expr->getName( $model->ParamList, "_AEact0_" ); + (my $actE_param, $err) = $model->ParamList->lookup($actE_name); + if ($err) { return undef, $err; } + + # remove trailing parens + $string_left =~ s/^\s*\)\s*//; + + # put name of rate parameter (or fcn) on the constants array + push @rate_constants, $phi_name, $actE_name; + if ($actE_param->Type eq "Function") + { push @rate_constants, @{$actE_param->Ref->Args}; } + } + elsif ( $string_left =~ /\S+/ ) + { + # Handle expression for rate constant of elementary reaction + # Read expression + my $expr = Expression->new(); + $expr->setAllowForward(1); # don't complain if expression refers to undefined parameters + $err = $expr->readString( \$string_left, $model->ParamList, "," ); + if ($err) { return '', $err; } + $expr->setAllowForward(0); + + # get name for ratelaw + my $name = $expr->getName( $model->ParamList, $basename, $force_fcn ); + # retreive param with this name + (my $param, $err) = $model->ParamList->lookup($name); + if ($err) { return '', $err; } + + my @local_args = (); + # determine ratelaw type + if (defined $param->Type) + { + if ( $param->Type eq "Constant" or $param->Type eq "ConstantExpression" ) + { # this is an elementary expression + $rate_law_type = "Ele"; + } + elsif ( $param->Type eq "Function" ) + { # this is a function expression.. + # check for local functions + if ( $totalRate and $expr->checkLocalDependency($model->ParamList) ) + { return undef, "TotalRate keyword is not compatible with local functions."; } + + $rate_law_type = "Function"; + push @local_args, @{$param->Ref->Args}; + } + else + { # we don't know how to handle this type of ratelaw + return undef, sprintf("Unable to construct Ratelaw with '%s' type parameter.", $param->Type); + } + } + else + { # this parameter is undefined, cannot determine the time + return undef, sprintf("Undefined parameter '%s' is referenced in Ratelaw.", $name); + } + + # put name of rate parameter (or fcn) on the constants array + push @rate_constants, $name, @local_args; + } + else + { # no ratelaw found + return undef, "No RateLaw supplied for Reaction Rule."; + } + + # Remove leading whitespace + $string_left =~ s/^\s*//; + # Done processing input string + $$strptr = $string_left; + + # Create new RateLaw object + my $rl = RateLaw->new( Type=>$rate_law_type, Constants=>[@rate_constants], TotalRate=>$totalRate, Factor=>$rate_fac ); + + # Validate rate law type + $err = $rl->validate($reactants,$model); + if ($err) { return undef, $err; } + + ++$n_RateLaw; + return $rl; +} + + +### +### +### + + +# Two basic formats are possible +# [stat_factor*]rate_constant +# or +# [stat_factor*]rate_law_name rate_constant1 rate_constant2 ... rate_constantN + +# create a new ratelaw from a .NET string +sub newRateLawNet +{ + my $strptr = shift @_; + my $plist = shift @_; + + my $string_left = $$strptr; + my $name; + my $rate_law_type; + my $rate_fac = 1; + my @rate_constants = (); + my $param; + my $err; + + # Find statistical factor for rate law + if ( $string_left =~ s/^([^*\s,]*)\*// ) + { + my $value; + ($param, $err) = $plist->lookup($1); + if ($param) + { + $value = $param->evaluate([], $plist); + } + else + { + unless (isReal($1)) + { return undef, "Coefficient for rate law ($1) must be a parameter or a real number"; } + + $value = $1; + } + $rate_fac = $value; + } + + # Get rate law type or name + if ( $string_left =~ s/^(\w+)\s*// ) + { $name = $1; } + else + { return undef, "Invalid rate law specification in $string_left"; } + + if ( $string_left =~ /^\S+/ ) + { + # Handle rate law type + $rate_law_type = $name; + + # Validate remaining rate constants + while ( $string_left =~ s/^(\w+)\s*// ) + { + my $rc = $1; + ( $param, $err ) = $plist->lookup($rc); + if ($err) { return ( '', $err ); } + push @rate_constants, $rc; + } + + if ( $string_left =~ /\S+/ ) + { return undef, "Invalid rate law syntax in $string_left"; } + } + else + { + if ( looks_like_number($name) ) + { # treat as a raw number + $rate_law_type = "Ele"; + push @rate_constants, $name; + } + else + { # look up parameter + ($param, $err) = $plist->lookup($name); + if ($err) { return undef, $err; } + + # determine ratelaw type + if ( $param->Type =~ /^Constant/ ) + { # this is an elementary expression + $rate_law_type = "Ele"; + } + else + { # this is a function + $rate_law_type = "Function"; + } + # TODO: handling for type "FunctionProduct" + + + # put name of rate parameter (or fcn) on the constants array + push @rate_constants, $name; + } + } + + # Remove leading whitespace + $string_left =~ s/^\s*//; + # Done processing input string + $$strptr = $string_left; + + # Create new RateLaw object + my $rl = RateLaw->new( Type=>$rate_law_type, Constants=>[@rate_constants], TotalRate=>0, Factor=>$rate_fac ); + + # Validate rate law type + $err = $rl->validate(); + if ($err) { return undef, $err; } + + ++$n_RateLaw; + return $rl; +} + + +### +### +### + + +# evaluate the RateLaw for the local reaction context +# +# things to accomplishs: +# (1) evaluate local functions +# (2) compute delta G contribution (energyBNGL) +# +# This method fingerprints and caches local ratelaws for efficient re-use +# +# $local_rl = $rl->evaluate_local( $rxn, $ref_map, $model ) +sub evaluate_local +{ + my ($rl, $rxn, $ref_map, $model) = @_; + + my $err; + my $local_rl = $rl; + if ($rl->Type eq "Arrhenius" ) + { + # TODO: verify that phi is a constant expression! (do this is ratelaw verify?) + # evaluate activation energy in local context and get activation energy fingerprint + my $local_expr; + my $lfcn_fingerprint; + my ($param) = $model->ParamList->lookup($rl->Constants->[1]); + if (defined $param and $param->Type eq "Function") + { + my $fcn = $param->Ref; + if ( $fcn->checkLocalDependency($model->ParamList) ) + { + # evaluate function locally + my @local_args = ( $fcn->Name, map {$ref_map->{$_}} @{$fcn->Args} ); + my $expr = Expression->new(Type=>"FunctionCall", Arglist=>[@local_args]); + $local_expr = $expr->evaluate_local($model->ParamList); + + # add to localfunc string to fingerprint + $lfcn_fingerprint = $rl->Constants->[0] . "," . $local_expr->toString($model->ParamList, 0, 2); + } + else + { # add to localfunc string to fingerprint + $lfcn_fingerprint = $rl->Constants->[0] . "," . $fcn->Name; + } + } + else + { # no local context in this parameter, create + # add to localfunc string to fingerprint + $lfcn_fingerprint = $rl->Constants->[0] . "," . $rl->Constants->[1]; + } + + # get deltaG fingerprint + my $fingerprint = "dir=" . $rxn->RxnRule->Direction; + $fingerprint .= ";energy=" . $rl->get_deltaG_fingerprint( $rxn, $model->EnergyPatterns ); + # add localfcn to fingerprint + $fingerprint .= ";local=" . $lfcn_fingerprint; + + # lookup fingerprint in RateLaw hash + if ( exists $rl->LocalRatelawsHash->{$fingerprint} ) + { # fetch ratelaw with this fingerprint + $local_rl = $rl->LocalRatelawsHash->{$fingerprint}; + } + else + { + # building arrhenius expression.. + # 1) get baseline activation energy + my $arrhenius_expr; + if (defined $local_expr) + { $arrhenius_expr = $local_expr; } + else + { $arrhenius_expr = Expression::newNumOrVar( $rl->Constants->[1], $model->ParamList ); } + + # 2a) compute deltaG terms + my @deltaG_terms = (); + foreach my $epatt ( @{$model->EnergyPatterns} ) + { + (my $expr, $err) = $epatt->getDeltaEnergy( $rxn, $model->ParamList ); + if (defined $expr) + { push @deltaG_terms, $expr; } + } + # 2b) computer overall deltaG + my $deltaG_expr; + if (@deltaG_terms>1) + { $deltaG_expr = Expression::operate("+", [@deltaG_terms], $model->ParamList); } + elsif (@deltaG_terms==1) + { $deltaG_expr = $deltaG_terms[0]; } + + # 3) compute phi term + my $phi_expr; + if ($rxn->RxnRule->Direction==1) + { # forward rule: phi + $phi_expr = Expression::newNumOrVar( $rl->Constants->[0], $model->ParamList ); + } + elsif ($rxn->RxnRule->Direction==-1) + { # reverse rule: (phi-1). NOTE: we use (phi-1) rather than (1-phi) since dG(+) = -dG(-) + $phi_expr = Expression::newNumOrVar( $rl->Constants->[0], $model->ParamList ); + $phi_expr = Expression::operate( "-", [1, $phi_expr], $model->ParamList ); + } + else + { die "ERROR: invalid direction (must be 1 or -1)"; } + + # 4) computer total activation energy + if (defined $deltaG_expr) + { + my $phi_deltaG_expr = Expression::operate("*", [$phi_expr, $deltaG_expr], $model->ParamList); + $arrhenius_expr = Expression::operate("+", [$arrhenius_expr, $phi_deltaG_expr], $model->ParamList); + } + + # 5) get negative exponential + $arrhenius_expr = Expression::operate("-", [$arrhenius_expr], $model->ParamList); + $arrhenius_expr = Expression::operate("FunctionCall", ["exp", $arrhenius_expr], $model->ParamList); + + # get parameter name for new ratelaw expression (if required) + my $base_name = $rxn->RxnRule->Name; # base parameter name is the rule name + $base_name =~ s/[^\w]+//g; # remove non-word characters + my $local_name = $arrhenius_expr->getName( $model->ParamList, "_${base_name}_local" ); + (my $local_param, $err) = $model->ParamList->lookup($local_name); + unless (defined $local_param) { die "RateLaw::evaluate_local() - Some problem creating param name for local ratelaw ($err)"; } + + # create new ratelaw + my $rl_type = $local_param->Type eq "Function" ? "Function" : "Ele"; + $local_rl = RateLaw->new( Type=>$rl_type, Constants=>[$local_name], Factor=>$rl->Factor, TotalRate=>0 ); + ++$RateLaw::n_Ratelaw; + + # add this local ratelaw to the LocalRatelawsHash + $rl->LocalRatelawsHash->{$fingerprint} = $local_rl; + } + } + elsif ( $rl->Type eq "FunctionProduct" ) + { + # TODO: implement + die "Error in RateLaw->evaluate_local(): FunctionProduct type RateLaw is not yet supported!"; + } + elsif ( $rl->Type eq "Function" ) + { + # get parameter corresponding to ratelaw function + (my $rl_param) = $model->ParamList->lookup($rl->Constants->[0]); + unless ( $rl_param->Type eq 'Function' ) + { die "Error in RateLaw->evaluate_local(): cannot find parameter for functional RateLaw!"; } + + # get function object + my $fcn = $rl_param->Ref; + # check for local dependency + if ( $fcn->checkLocalDependency($model->ParamList) ) + { + # evaluate function locally + my @local_args = ( $fcn->Name, map {$ref_map->{$_}} @{$fcn->Args} ); + my $expr = Expression->new(Type=>"FunctionCall", Arglist=>[@local_args]); + my $local_expr = $expr->evaluate_local($model->ParamList); + #if (defined $conv_expr) + #{ $local_expr = Expression::operate("*", [$conv_expr, $local_expr], $model->ParamList); } + + # add to localfunc string to fingerprint + my $fingerprint = $local_expr->toString($model->ParamList, 0, 2); + + # lookup localfcn fingerprint in hash + if ( exists $rl->LocalRatelawsHash->{$fingerprint} ) + { # fetch the original localfcn + $local_rl = $rl->LocalRatelawsHash->{$fingerprint}; + } + else + { # build a new ratelaw + # get parameter name for new ratelaw expression (if required) + my $base_name = $rxn->RxnRule->Name; # base parameter name is the rule name + $base_name =~ s/[^\w]+//g; # remove non-word characters + my $local_name = $local_expr->getName( $model->ParamList, "_${base_name}_local" ); + (my $local_param, $err) = $model->ParamList->lookup($local_name); + unless (defined $local_param) { die "RateLaw::evaluate_local() - Some problem creating param name for local ratelaw ($err)"; } + + # create new ratelaw + my $rl_type = $local_param->Type eq "Function" ? "Function" : "Ele"; + $local_rl = RateLaw->new( Type=>$rl_type, Constants=>[$local_name], Factor=>$rl->Factor, TotalRate=>0 ); + ++$RateLaw::n_Ratelaw; + + # add this ratelaw to LocalRatelawsHash + $rl->LocalRatelawsHash->{$fingerprint} = $local_rl; + } + } + } + + return $local_rl; +} + + +### +### +### + + +sub get_deltaG_fingerprint +{ + my ($rl, $rxn, $epatts) = @_; + # gather stoichiometry of each energy pattern under this reaction + my ($err, $stoich); + my @fingerprint = (0) x @$epatts; + foreach my $ii (0 .. $#$epatts) + { ($fingerprint[$ii], $err) = $epatts->[$ii]->getStoich($rxn); } + # return fingerprint + return join(",", @fingerprint); +} + + +### +### +### + + +sub equivalent +{ + my $rl1 = shift @_; + my $rl2 = shift @_; + my $plist = (@_) ? shift : undef; + + my $err; + + # first make sure we're dealing with defined ratelaws + return 0 unless ( defined $rl1 and (ref $rl1 eq 'RateLaw') + and defined $rl2 and (ref $rl2 eq 'RateLaw') ); + + # shortcut return true if we're looking at the same ratelaw object + return 1 if ( $rl1 == $rl2 ); + + # compare type + return 0 unless ( $rl1->Type eq $rl2->Type ); + # compare number of constants + return 0 unless ( @{$rl1->Constants} == @{$rl2->Constants} ); + # compare factor + return 0 unless ( $rl1->Factor == $rl2->Factor ); + # compare totalrate flag + return 0 unless ( $rl1->TotalRate eq $rl2->TotalRate ); + + if ( $rl1->Type eq 'Function' ) + { + # check function equivalence: (ignore name) + (my $par1, $err) = $plist->lookup( $rl1->Constants->[0] ); + if ($err) { return 0; } + + (my $par2, $err) = $plist->lookup( $rl2->Constants->[0] ); + if ($err) { return 0; } + + return 0 unless ( Function::equivalent($par1->Ref, $par2->Ref, $plist) ); + } + else + { + # compare arguments (all arguments are parameter names) + for ( my $i = 0; $i < @{$rl1->Constants}; ++$i ) + { return 0 unless ( $rl1->Constants->[$i] eq $rl2->Constants->[$i] ); } + } + # TODO: handling for FunctionProduct + + # no difference found, the ratelaws are equivalent + return 1; +} + + +### +### +### + + +# write ratelaw as a string +sub toString +{ + my $rl = shift @_; + my $stat_factor = @_ ? shift @_ : undef; + my $netfile = @_ ? shift @_ : 0; + my $plist = @_ ? shift @_ : undef; + my $conv_expr = @_ ? shift @_ : undef; # expression for unit conversions + + my $string = ''; + + # ratelaw factor + my $ratelaw_mult = undef; + if ( defined $rl->Factor and $rl->Factor != 1 ) + { $ratelaw_mult = Expression::newNumOrVar($rl->Factor); } + + # statistical factor + if ( defined $stat_factor and $stat_factor != 1 ) + { + if ( defined $ratelaw_mult ) + { $ratelaw_mult = Expression::operate('*', [$ratelaw_mult, $stat_factor], $plist); } + else + { $ratelaw_mult = Expression::newNumOrVar($stat_factor); } + } + + # unit conversions + if (defined $conv_expr) + { + if (defined $ratelaw_mult) + { $ratelaw_mult = Expression::operate('*', [$ratelaw_mult, $conv_expr], $plist); } + else + { $ratelaw_mult = $conv_expr; } + } + + # evaluate multiplier + if (defined $ratelaw_mult) { $string .= sprintf("%.8g", $ratelaw_mult->evaluate($plist)) . "*"; } + + # now write the ratelaw to the string + my $type = $rl->Type; + if ( $type eq "Ele" ) + { + # nothing more to do.. just write the rate constant + $string .= $rl->Constants->[0]; + } + elsif ( $type eq "Function" ) + { + $string .= $rl->Constants->[0]; + unless ($netfile) + { # write arguments + my $last = @{$rl->Constants}-1; + $string .= '(' . join(',', @{$rl->Constants}[1..$last]) . ')'; + } + } + elsif ( $type eq "FunctionProduct" ) + { + $string .= 'FunctionProduct("'; + $string .= $rl->Constants->[0] . '(' . join(',', @{$rl->Constants->[2]}) . ')'; + $string .= '","'; + $string .= $rl->Constants->[1] . '(' . join(',', @{$rl->Constants->[3]}) . ')'; + $string .= '")'; + } + elsif ( $type eq "Arrhenius" ) + { + my $last = @{$rl->Constants}-1; + $string .= 'Arrhenius('; + $string .= $rl->Constants->[0] . ','; + $string .= $rl->Constants->[1]; + if (@{$rl->Constants} > 2){ + $string .= '(' . join(',', @{$rl->Constants}[2..$last]) . ')'; + } + $string .= ')'; + } + else + { # Sat, MM, Hill + if ($netfile){ + $string.= $type . " " . join(' ', @{$rl->Constants}); + } else { + $string.= $type . "(" . join(',', @{$rl->Constants}) . ")"; + } + } + + return $string; +} + + +### +### +### + + +# write ratelaw as a CVode formula +sub toCVodeString +{ + my $rl = shift @_; + my $stat_factor = shift @_; + my $reactants = shift @_; + my $rrefs = shift @_; + my $plist = @_ ? shift @_ : undef; + my $conv_expr = @_ ? shift @_ : undef; # expression for unit conversions + + # ratelaw factor + my $ratelaw_mult = undef; + if ( defined $rl->Factor and $rl->Factor != 1 ) + { $ratelaw_mult = Expression::newNumOrVar($rl->Factor); } + + # statistical factor + if ( defined $stat_factor and $stat_factor != 1 ) + { + if ( defined $ratelaw_mult ) + { $ratelaw_mult = Expression::operate('*', [$ratelaw_mult, $stat_factor], $plist); } + else + { $ratelaw_mult = Expression::newNumOrVar($stat_factor); } + } + + # unit conversions + if (defined $conv_expr) + { + if (defined $ratelaw_mult) + { $ratelaw_mult = Expression::operate('*', [$ratelaw_mult, $conv_expr], $plist); } + else + { $ratelaw_mult = $conv_expr; } + } + + # begin gather ratelaw terms + my @rl_terms = (); + if (defined $ratelaw_mult) { push @rl_terms, $ratelaw_mult->toCVodeString( $plist ); } + + my $type = $rl->Type; + my $rate_constants = $rl->Constants; + + if ( $type eq "Ele" ) + { + # look up parameter + (my $const) = $plist->lookup( $rate_constants->[0] ); + + # get rate constant + push @rl_terms, $const->getCVodeName(); + #push @rl_terms, $const->toCVodeString($plist); + + # get reactant species + foreach my $reactant ( @$reactants ) + { + # add CVode ref to this reactant species + push @rl_terms, $reactant->getCVodeName; + } + } + elsif ( $type eq 'Function' ) + { # assume the function arguments are evaluated.. + # only need to worry about observables and such.. + + # look up parameter + (my $fcn_param) = $plist->lookup( $rate_constants->[0] ); + + my $fcn = $fcn_param->Ref; + + # get CVodeRefs for tagged reactants + # TODO: this may be obsolete due to local fnc evaluation + my @fcn_args = (); + if ( @{$fcn->Args} ) + { + if ( ref $rrefs eq 'HASH' ) + { + foreach my $tag ( @{$fcn->Args} ) + { + unless ( (exists $rrefs->{$tag}) and (exists $reactants->[$rrefs->{$tag}]) ) + { return "could not find reactant or tag corresponding to ratelaw argument!"; } + + push @fcn_args, ($reactants->[$rrefs->{$tag}])->getCVodeName; + } + } + else + { return "ratelaw depends on tagged reactants and RRefs hash is missing!"; } + } + + # add references to the expressions and observables arrays + #push @rl_terms, $fcn->toCVodeString( $plist, {'fcn_mode' => 'call'}); + push @fcn_args, 'expressions', 'observables'; + push @rl_terms, $fcn->Name . '(' . join( ',', @fcn_args ) . ')'; + + # get reactant species + foreach my $reactant ( @$reactants ) + { # add CVode ref to this reactant species + push @rl_terms, $reactant->getCVodeName; + } + } + else + { return "Ratelaws of type $type are not yet supported by writeMexfile()"; } + + # build ratelaw string + return join('*', @rl_terms); +} + + +### +### +### + + +# write ratelaw as a CVode formula +sub toMatlabString +{ + my $rl = shift @_; + my $stat_factor = shift @_; + my $reactants = shift @_; + my $rrefs = shift @_; + my $plist = @_ ? shift @_ : undef; + my $conv_expr = @_ ? shift @_ : undef; # expression for unit conversions + + # ratelaw factor + my $ratelaw_mult = undef; + if ( defined $rl->Factor and $rl->Factor != 1 ) + { $ratelaw_mult = Expression::newNumOrVar($rl->Factor); } + + # statistical factor + if ( defined $stat_factor and $stat_factor != 1 ) + { + if ( defined $ratelaw_mult ) + { $ratelaw_mult = Expression::operate('*', [$ratelaw_mult, $stat_factor], $plist); } + else + { $ratelaw_mult = Expression::newNumOrVar($stat_factor); } + } + + # unit conversions + if (defined $conv_expr) + { + if (defined $ratelaw_mult) + { $ratelaw_mult = Expression::operate('*', [$ratelaw_mult, $conv_expr], $plist); } + else + { $ratelaw_mult = $conv_expr; } + } + + # begin gather ratelaw terms + my @rl_terms = (); + if (defined $ratelaw_mult) { push @rl_terms, $ratelaw_mult->toMatlabString( $plist ); } + + my $type = $rl->Type; + my $rate_constants = $rl->Constants; + + if ( $type eq "Ele" ) + { + # look up parameter + (my $const) = $plist->lookup( $rate_constants->[0] ); + + # get rate constant + push @rl_terms, $const->toMatlabString($plist); + + # get reactant species + foreach my $reactant ( @$reactants ) + { # add CVode ref to this reactant species + push @rl_terms, $reactant->getMatlabName(); + } + } + elsif ( $type eq 'Function' ) + { + # look up parameter + (my $fcn_param) = $plist->lookup( $rate_constants->[0] ); + + my $fcn = $fcn_param->Ref; + + # get MatlabRefs for tagged reactants + # TODO: this may be obsolete due to local fnc evaluation + my @fcn_args = (); + if ( @{$fcn->Args} ) + { + if ( ref $rrefs eq 'HASH' ) + { + foreach my $tag ( @{$fcn->Args} ) + { + unless ( (exists $rrefs->{$tag}) and (exists $reactants->[$rrefs->{$tag}]) ) + { return "could not find reactant or tag corresponding to ratelaw argument!"; } + + push @fcn_args, ($reactants->[$rrefs->{$tag}])->getMatlabName(); + } + } + else + { return "ratelaw depends on tagged reactants and RRefs hash is missing!"; } + } + + # TODO: move this functionality to Function class. + push @fcn_args, 'expressions', 'observables'; + push @rl_terms, $fcn->Name . '(' . join( ',', @fcn_args ) . ')'; + + # get reactant species + foreach my $reactant ( @$reactants ) + { + # add CVode ref to this reactant species + push @rl_terms, $reactant->getMatlabName(); + } + } + else + { return "Ratelaws of type $type are not yet supported by writeMfile()"; } + + # build ratelaw string + return join('*', @rl_terms); +} + + + +### +### +### + + +# write ratelaw in XML format +sub toXML +{ + my $rl = shift @_; + my $indent = shift @_; + my $rr_id = @_ ? shift @_ : ''; # rxn rule id + my $plist = @_ ? shift @_ : undef; # parameter list + my $rrefs = @_ ? shift @_ : undef; # rxnrule reference hash + + if ( $rl->Type eq "Function" ) + { # separate handling for Function ratelaws + return $rl->toXMLFunction($indent, $rr_id, $plist, $rrefs); + } + + if ( $rl->Type eq "FunctionProduct" ) + { # separate handling for FunctionProduct ratelaws + return $rl->toXMLFunctionProduct($indent, $rr_id, $plist, $rrefs); + } + + # handle other ratelaw types + # define ratelaw id + my $id; + if ( $rr_id ) + { $id = $rr_id . "_RateLaw"; } + else + { $id = "RateLaw" . $RateLaw::n_RateLaw; } + + # begin XML string + my $string = $indent . "Type . "\""; + # total rate attribute + $string .= " totalrate=\"" . $rl->TotalRate . "\""; + + # StatFactor (Is this used anymore?? --Justin) + unless ( $rl->Factor == 1 ) + { $string .= " statFactor=\"" . $rl->Factor . "\""; } + + # Objects contained + my $ostring = ""; + my $indent2 = " " . $indent; + + $ostring .= $indent2 . "\n"; + foreach my $rc ( @{$rl->Constants} ) + { + my $indent3 = " " . $indent2; + ### How to handle references to named parameters? + $ostring .= $indent3 . "\n"; + + # Termination + if ($ostring) + { + $string .= ">\n"; + $string .= $ostring; + $string .= $indent . "\n"; + } + else + { $string .= "/>\n"; } + + return $string; +} + + +### +### +### + + +sub toXMLFunction +{ + my $rl = shift; + my $indent = shift; + my $rr_id = (@_) ? shift : ''; # rxn rule id + my $plist = (@_) ? shift : undef; # parameter list + my $rrefs = (@_) ? shift : undef; # rxnrule reference hash + + # define ratelaw id + my $id; + if ( $rr_id ) + { $id = $rr_id . "_RateLaw"; } + else + { $id = "RateLaw" . $RateLaw::n_RateLaw; } + + + # Write ratelaw header and attributes: + my $string = $indent . "Type . "\""; + # reference + $string .= " name=\"" . $rl->Constants->[0] . "\""; + # total rate attribute + $string .= " totalrate=\"" . $rl->TotalRate . "\""; + # end of attributes + $string .= ">\n"; + + # Write References + my $indent2 = $indent.' '; + my ( $param, $err ) = $plist->lookup( $rl->Constants->[0] ); + my $fun = $param->Ref; + $string .= $indent2 . "\n"; + foreach my $arg ( @{$fun->Args} ) + { + my $indent3 = $indent2.' '; + my $ptr = $rrefs->{$arg}; + my $oid = RxnRule::pointer_to_ID( $rr_id . "_R", $ptr ); + $string .= $indent3 . "\n"; + + # Termination + $string .= $indent . "\n"; + + return ($string); +} + + +### +### +### + + +sub toXMLFunctionProduct +{ + my $rl = shift @_; + my $indent = shift @_; + my $rr_id = @_ ? shift @_ : ''; # rxn rule id + my $plist = @_ ? shift @_ : undef; # parameter list + my $rrefs = @_ ? shift @_ : undef; # rxnrule reference hash + + my $err; + + # define ratelaw id + my $id; + if ( $rr_id ) + { $id = $rr_id . "_RateLaw"; } + else + { $id = "RateLaw" . $RateLaw::n_RateLaw; } + + + # Write ratelaw header and attributes: + my $string = $indent . "Type . "\""; + # references + $string .= " name1=\"" . $rl->Constants->[0] . "\""; + $string .= " name2=\"" . $rl->Constants->[1] . "\""; + # total rate attribute + $string .= " totalrate=\"" . $rl->TotalRate . "\""; + # end of attributes + $string .= ">\n"; + + # Write References + my $indent2 = $indent.' '; + (my $param1, $err) = $plist->lookup( $rl->Constants->[0] ); + my $fun1 = $param1->Ref; + $string .= $indent2 . "\n"; + foreach my $arg ( @{$fun1->Args} ) + { + my $indent3 = $indent2.' '; + my $ptr = $rrefs->{$arg}; + my $oid = RxnRule::pointer_to_ID( $rr_id . "_R", $ptr ); + $string .= $indent3 . "\n"; + + # Write References + $indent2 = $indent.' '; + (my $param2, $err) = $plist->lookup( $rl->Constants->[1] ); + my $fun2 = $param2->Ref; + $string .= $indent2 . "\n"; + foreach my $arg ( @{$fun2->Args} ) + { + my $indent3 = $indent2.' '; + my $ptr = $rrefs->{$arg}; + my $oid = RxnRule::pointer_to_ID( $rr_id . "_R", $ptr ); + $string .= $indent3 . "\n"; + + # Termination + $string .= $indent . "\n"; + + return ($string); +} + + +### +### +### + + +# WARNING: Checking here is minimal +sub validate +{ + my $rl = shift @_; + my $reactants = @_ ? shift @_ : undef; + my $model = @_ ? shift @_ : undef; + + if ( $rl->Type eq "Ele" ) + { + + } + elsif ( $rl->Type eq "Sat" ) + { + if ( @{$rl->Constants} < 2 ) + { # Too few rate constants + return "Saturation type ratelaws require at least 2 rate constants"; + } + if ( defined $reactants ) + { + if ( @{$rl->Constants} > @{$reactants} + 1 ) + { # more saturations constants than reactants + return "Saturation type ratelaws cannot have more saturation constants than reactants"; + } + } + } + elsif ( $rl->Type eq "MM" ) + { + if ( @{$rl->Constants} != 2 ) + { # incorrect number of rate constants + return "Michaelis-Menton type ratelaws require exactly 2 rate constants"; + } + if ( defined $reactants ) + { + if (@{$reactants} != 2 ) + { # incorrect number of reactants + return "Michaelis-Menton type ratelaw require exactly 2 reactants (e.g. Substrate + Enzyme)"; + } + if ( ref $reactants->[0] eq 'SpeciesGraph' and ref $reactants->[1] eq 'SpeciesGraph' ) + { + if ( $reactants->[0]->isomorphicToSubgraph($reactants->[1]) + and $reactants->[1]->isomorphicToSubgraph($reactants->[0]) ) + { # reactants are identical! + return "Michaelis-Menton type ratelaw requires non-identical reactants (e.g. Substrate + Enzyme)"; + } + + if ( defined $model ) + { + my $err = $model->MoleculeTypesList->checkSpeciesGraph( $reactants->[0], + { IsSpecies => 1, + AllowNewTypes => 0 } ); + if ( $err ) + { # substrate reactant can potentially match multiple species + send_warning( "In rule with Michaelis-Menton type ratelaw:\n" + ." substrate reactant pattern may match more than one species.\n" + ." This may yield unexpected results in Network simulations."); + } + } + } + } + } + elsif ( $rl->Type eq "Hill" ) + { + if ( @{$rl->Constants} != 3 ) + { # incorrect number of rate constants + return "Hill type ratelaws require exactly 3 rate constants"; + } + } + elsif ( $rl->Type eq "Function" ) + { + # Validate local arguments here ? + } + elsif ( $rl->Type eq "FunctionProduct" ) + { + # Validate local arguments here ? + } + elsif ( $rl->Type eq "Arrhenius" ) + { + # Validate local arguments here ? + # TODO: 1) verify that phi is not a function + # 2) verify that actE is independent of deltaG (is this possible here?) + } + else + { return sprintf("Unrecognized RateLaw type %s", $rl->Type); } + + return undef; +} + + + +### +### +### + + +sub toLatexString +{ + my $rl = shift; + my $reactants = shift; + my $statFactor = shift; + my $plist = shift; + my $string = ''; + + my @k = @{ $rl->Constants }; + my $type = $rl->Type; + + $statFactor *= $rl->Factor; + + my %pindex = (); + foreach my $index ( 0 .. $#{ $plist->Array } ) + { + my $pname = $plist->Array->[$index]->Name; + $pindex{$pname} = $index + 1; + } + + if ( $type eq "Ele" ) + { + if ( $statFactor != 1 ) + { + $string .= "$statFactor "; + } + $string .= "p_{" . $pindex{ $k[0] } . "}"; + foreach my $reac (@$reactants) + { + $string .= " x_{" . $reac->Index . "}"; + } + } + else + { + return "", "Unrecognized RateLaw type $type in toLatexString()"; + } + return $string, ''; +} + + +### +### +### + + +sub toMathMLString +{ + my $rl = shift; + my $rindices = shift; + my $pindices = shift; + my $statFactor = (@_) ? shift : 1; + my $comp_name = (@_) ? shift : undef; + my $string = ''; + + my @k = @{ $rl->Constants }; + my $type = $rl->Type; + + $string .= "\n"; + + $statFactor *= $rl->Factor; + + +# if ( $type eq "Ele" ) + if ( $type eq "Ele" | $type eq "Function" ) + { + # $statFactor*$k[0]*reactant1*...*reactantN + $string .= " \n \n"; + if ( $statFactor != 1 ) + { + $string .= " $statFactor \n"; + } + $string .= sprintf " %s \n", $k[0]; + for my $i (@$rindices) + { + $string .= sprintf " S%d \n", $i; + } + # add volume correction if given + if ( defined $comp_name ) + { + $string .= " $comp_name \n"; + } + # done adding volume correction + $string .= " \n"; + } + elsif ( $type eq 'Sat' ) + { + # NOTE: THIS CODE IS NOT TESTED! + # One parameter: + # rate = $statFactor*$k[0] + # Two or more parameters (N denominator terms, N+1 parameters) + # rate = $statFactor*$k[0]*reactant1*...*reactantN/(($k[1]+reactant1)*...*($k[N]+reactantN) + if ( $#k == 0 ) + { + if ( $statFactor != 1 ) + { + $string .= " \n"; + $string .= " \n"; + $string .= " $statFactor \n"; + $string .= sprintf " %s \n", $k[0]; + $string .= " \n"; + } + else + { + $string .= sprintf " %s \n", $k[0]; + } + } + else + { + $string .= " \n"; + $string .= " \n"; + + $string .= " \n"; + $string .= " \n"; + if ( $statFactor != 1 ) + { + $string .= " $statFactor \n"; + } + $string .= sprintf " %s \n", $k[0]; + foreach my $i (@$rindices) + { + $string .= sprintf " S%d \n", $i; + } + $string .= " \n"; + my $indentp = " "; + if ( $#k > 1 ) + { + $string .= $indentp . "\n"; + $string .= $indentp . "\n"; + $indentp .= " "; + } + foreach my $ik ( 1 .. $#k ) + { + $string .= $indentp . "\n"; + $string .= $indentp . "\n"; + $string .= sprintf "%s %s \n", $indentp, $k[$ik]; + $string .= sprintf "%s S%d \n", $indentp, + $$rindices[ $ik - 1 ]; + $string .= $indentp . "\n"; + } + if ( $#k > 1 ) + { + $indentp =~ s/ $//; + $string .= $indentp . "\n"; # end times + } + $string .= " \n"; # end divide + } + } + elsif ( $type eq 'MM' ) + { + return '', "Michaelis-Menton type reactions are not curently handled."; + } + else + { + return '', "Unrecognized RateLaw type $type in toMathMLString()"; + } + + $string .= "\n"; + + return $string, ''; +} + + + +### +### +### + +1; diff --git a/libvcell/vcell_install/bionetgen/Perl2/RefineRule.pm b/libvcell/vcell_install/bionetgen/Perl2/RefineRule.pm new file mode 100644 index 0000000..37e8bb4 --- /dev/null +++ b/libvcell/vcell_install/bionetgen/Perl2/RefineRule.pm @@ -0,0 +1,769 @@ +package RxnRule; + +use strict; +use warnings; + + +### +### +### + + +# parse population mapping string and return a RxnRule object +sub newPopulationMappingRule +{ + # get input arguments + my $string = shift @_; + my $model = shift @_; + + # define return arguments + my $err = undef; + my $rr = undef; + + # Remove leading whitespace + $string =~ s/^\s*//; + + my $name = ''; + # check for rule identifier or index + if ( $string =~ s/^([\w\s*]+):\s*// ) + { # if the first token is alphanumeric and followed by a colon, + # then its the name of the rule + $name = $1; + } + elsif ( $string =~ s/^(\d+)\s+// ) + { # if the first token is a number, this is the rule index + $name = $1; + } + + + # some local variables + my ( $ipatt, $g, $sep, $reversible ); + + # data structures for reactants, products and references + my $reac = []; + my $prod = []; + my $rrefs = {}; + my $prefs = {}; + # temporary structure to map references from reactants to products + my %labels = (); + + + # Read reactant patterns + $sep = '^\s*[+]\s*|^\s*([<]?-[>])\s*'; # "+" or "->" or "<->" + $ipatt = -1; + while ($string) + { + $g = SpeciesGraph->new(); + # use the MoleculeTypes list for reactant validation + $err = $g->readString( \$string, $model->CompartmentList, SpeciesGraph::IS_SPECIES(), + $sep, $model->MoleculeTypesList ); + if ($err) { return ($err, $rr); } + ++$ipatt; + + # Check Labels for this Reactant: + if ( defined $g->Label and $g->Label ne '' ) + { + $rrefs->{ $g->Label } = $ipatt; + } + + # Checking Molecules... + my $imol = -1; + foreach my $mol ( @{ $g->Molecules } ) + { + ++$imol; + my $label = $mol->Label; + if ( defined $label and $label ne '' ) + { + if ( $labels{$label} ) + { + return ("Repeated label $label in reactants of reactant rule", $rr); + } + $labels{$label} = 'M'; + $rrefs->{$label} = join '.', ($ipatt, $imol); + } + my $icomp = -1; + + # Checking Components... + foreach my $comp ( @{ $mol->Components } ) + { + ++$icomp; + $label = $comp->Label; + if ( defined $label and $label ne '' ) + { + if ( $labels{$label} ) + { + return ("Repeated label $label in reactants of reaction rule", $rr); + } + $labels{$label} = 'C'; + $rrefs->{$label} = join '.', ($ipatt, $imol, $icomp); + } + } + } + + # Save this reactant + push @$reac, $g; + + # Find next separator (some problem with string if there is no separator) + unless ( $string =~ s/$sep// ) + { + return ("Invalid syntax in reaction rule: $string", $rr); + } + + # If the arrow operator was the next separator, then it's captured in $1 + if ($1) + { # Check if this reaction is reversible + $reversible = ( $1 eq "<->" ) ? 1 : 0; + if ( $reversible ) + { return ("Population mapping rule should not be reversible!", $rr); } + last; + } + } + # only 1 reactant pattern allowed in population mapping rule + unless (@$reac == 1) + { return ("Incorrect number of reactants in population mapping rule!", $rr); } + + + + # Read Product Patterns + $sep = '^\s*([+])\s*|^\s+'; # "+" or " " + $ipatt = -1; + while ($string) + { + my $g = SpeciesGraph->new(); + # Validate product graphs using population types + $err = $g->readString( \$string, $model->CompartmentList, SpeciesGraph::IS_SPECIES(), + $sep, $model->PopulationTypesList ); + if ($err) { return ($err, $rr); } + ++$ipatt; + + + # Check that pattern is a single molecule + unless ( @{$g->Molecules} == 1 ) + { + return ("Incorrect number of molecules in product of population mapping rule!", $rr); + } + # Check that population type does not collide with anything in the molecule type list + if ( defined $model->MoleculeTypesList->findMoleculeType($g->Molecules->[0]->Name) ) + { + return ("Population product type collides with a previously defined molecule type!", $rr); + } + # Check that the molecule does not have components + unless ( @{$g->Molecules->[0]->Components} == 0 ) + { + return ("Components are not permitted in product of population mapping rule!", $rr); + } + + + # Checking Labels for this Species.. + if ( defined $g->Label and $g->Label ne '' ) + { + $prefs->{ $g->Label } = $ipatt; + } + + # Checking Molecules... (verify correspondence and uniqueness!) + my $imol = -1; + foreach my $mol ( @{$g->Molecules} ) + { + ++$imol; + my $label = $mol->Label; + if ( defined $label and $label ne '' ) + { + if ( $labels{$label} eq 'M' ) + { + $labels{$label} = 'found'; + } + elsif ( $labels{$label} eq 'found' ) + { + return ("Repeated label $label in products of reaction rule $name", $rr); + } + else + { + return ("Mis- or un-matched label $label in products of reaction rule $name", $rr); + } + $prefs->{$label} = join '.', ($ipatt, $imol); + } + + # Checking Components... + my $icomp = -1; + foreach my $comp ( @{$mol->Components} ) + { + ++$icomp; + $label = $comp->Label; + + #print "label=$label\n"; + if ( defined $label and $label ne '' ) + { + if ( $labels{$label} eq 'C' ) + { + $labels{$label} = 'found'; + } + elsif ( $labels{$label} eq 'found' ) + { + return ("Repeated label $label in products of reaction rule $name", $rr); + } + else + { + return ("Mis- or un-matched label $label in products of reaction rule $name", $rr); + } + $prefs->{$label} = join '.', ($ipatt, $imol, $icomp); + } + } + } + + # Save this Product pattern + push @$prod, $g; + + # Check for next separator (store a "+" separator in $1) + $string =~ s/$sep//; + + # See if there's more Products to parse.. + last unless $1; + } + # only 1 product pattern allowed in population mapping rule + unless (@$prod == 1) + { return ("Incorrect number of products in population mapping rule!", $rr); } + + + + # Read rateLaw + my $rl; + + # Look for TotalRate attribute + # (default behavior is PerSite rate) + my $TotalRate = 0; + if ( $string =~ s/(^|\s)TotalRate(\s|$)/$2/ ) + { $TotalRate = 1; } + + # temporarily add Reference tags as names in the ParamList + if (%$rrefs) { setRefs( $rrefs, '', $model->ParamList ); } + + # Parse and Create the ratelaw + ( $rl, $err ) = RateLaw::newRateLaw( \$string, $model, $TotalRate, $reac ); + if ($err) { return ($err, $rr); } + + # unset temporary names of Reference tags + if (%$rrefs) { unsetRefs( $rrefs, $model->ParamList ); } + + + # Check for syntax error due to extra ratelaw tokens + if ( $string =~ /^\s*[,]/ ) + { return ("Unidirection reaction may have only one rate law", $rr); } + + # String should be empty now, otherwise there may be a problem. + if ( $string =~ /\S+/ ) + { return ("Syntax error in reaction rule at $string", $rr); } + + + + # Construct RxnRule + $rr = RxnRule->new(); + if ($name) { $rr->Name($name); } + $rr->Reactants( $reac ); + $rr->Products( $prod ); + $rr->Priority( 0 ); + $rr->RateLaw( $rl ); + $rr->Rexclude( [([])] ); + $rr->Pexclude( [([])] ); + $rr->Rinclude( [([])] ); + $rr->Pinclude( [([])] ); + $rr->TotalRate( $TotalRate ); + $rr->DeleteMolecules( 0 ); + $rr->MoveConnected( 0 ); + $rr->RRefs( $rrefs ); + $rr->PRefs( $prefs ); + + # Find mapping of reactants onto products + # (pass population types list for handling of created populations + if ( $err = $rr->findMap($model->PopulationTypesList) ) + { return ($err, $rr); } + + # Return normally + return ($err, $rr); +} + + + +### +### +### + + + +##------------## +## expandRule ## +##------------## +sub expandRule +{ + # get input arguments + my $rr = shift @_; # this reaction rule + my $sg_list = shift @_; # expand rules w.r.t. these species graphs + my $model = shift @_; # model + my $hybrid_model = shift @_; # new hybrid model + my $user_params = (@_) ? shift : {}; + + + # Specify default params + my $params = { verbose => 0, + indent => ' ' x 8, + safe => 0 + }; + # overwrite defaults with user params + while ( my ($opt,$val) = each %$user_params ) + { $params->{$opt} = $val; } + + + # define return values + my $err = undef; + my $child_rule_list = []; + my $child_rule_map = {}; + + # clear out the RxnLabels hash + %{$rr->RxnLabels} = (); + + # remember number of reactants + my $n_reactants = scalar @{$rr->Reactants}; + + + # Map Reactant Patterns into SpeciesGraphs in @$patterns + my $ipatt = 0; + foreach my $patt ( @{$rr->Reactants} ) + { + # make sure rmatches is empty! + $rr->Rmatches->[$ipatt] = []; + if ( $params->{safe} ) + { + # add self-embedding of reactant pattern its match list + my $copy_patt = $patt->copy( !SpeciesGraph::COPY_LABEL(), SpeciesGraph::GET_LABEL() ); + (my $copy_match) = $patt->isomorphicToSubgraph($copy_patt); + push @{$rr->Rmatches->[$ipatt]}, $copy_match; + + } + else + { + # check if reactant is isomorphic to anything in sg_list + my $is_isomorph = 0; + foreach my $sg (@$sg_list) + { + # NOTE: since $sg is a fully specified species, looking for a subgraph isomorphism in $rpatt + # is sufficient for establishing isomorphism. This is slower than the method 'isomorphicTo' + # but does not require sorting molecules (which is problematic for reactant patterns). + if ( $sg->isomorphicToSubgraph($patt) ) + { + $is_isomorph = 1; + last; + } + } + unless ($is_isomorph) + { + # add self-embedding of reactant pattern its match list + my $copy_patt = $patt->copy( !SpeciesGraph::COPY_LABEL(), SpeciesGraph::GET_LABEL() ); + (my $copy_match) = $patt->isomorphicToSubgraph($copy_patt); + push @{$rr->Rmatches->[$ipatt]}, $copy_match; + } + } + + # find all matches in $sg_list. load maps into Rmatches. + #my $n_matches = $rr->find_reactant_matches( $ipatt, $sg_list, $model ); + my $new_matches = $rr->find_embeddings( $ipatt, $sg_list, $model ); + push @{$rr->Rmatches->[$ipatt]}, @$new_matches; + + if ( $params->{verbose} ) + { + my $tot_matches = @{$rr->Rmatches->[$ipatt]}; + printf $params->{indent} . " ..found %d match%s to reactant pattern %d\n", + $tot_matches, ($tot_matches==1 ? '' : 'es'), $ipatt+1; + } + ++$ipatt; + } + + + # create CartesianProduct object to iterate over all rule instances + my $rule_instances = CartesianProduct::new(); + $rule_instances->initialize( $rr->Rmatches ); + + # loop over every reactant set + my $rule_instance = []; + while ( $rule_instances->getNext($rule_instance) ) + { + # get child rule by restricting rule to the rule_instance + my $child_rule = $rr->restrict_rule( $rule_instance, $model, $hybrid_model, $params ); + next unless ( defined $child_rule ); + + if ( exists $child_rule_map->{$child_rule->StringID} ) + { + my $multiplicity = $child_rule->RateLaw->Factor; + my $prior_child_rule = $child_rule_map->{$child_rule->StringID}; + $prior_child_rule->RateLaw->Factor( $prior_child_rule->RateLaw->Factor + $multiplicity ); + } + else + { + $child_rule_map->{$child_rule->StringID} = $child_rule; + push @$child_rule_list, $child_rule; + } + } + + foreach my $child_rule ( @$child_rule_list ) + { + # add statFactor into the RateLaw constant + my $ratelaw = $child_rule->RateLaw; + unless ( $ratelaw->Factor == 1.0 ) + { + # get rate parameter + my $param_name = $ratelaw->Constants->[0]; + my ($rate_param,$err) = $hybrid_model->ParamList->lookup($param_name); + # multiply rate parameter by Factor + my $new_rate_expr = Expression::operate( '*', [$ratelaw->Factor, $rate_param->Expr], $hybrid_model->ParamList ); + my $new_param_name = $new_rate_expr->getName( $hybrid_model->ParamList, $param_name.'_' ); + $ratelaw->Constants->[0] = $new_param_name; + # set statFactor to 1 + $ratelaw->Factor(1); + } + } + + %{$child_rule_map} = (); + return ($err, $child_rule_list); +} + + + +### +### +### + + + +# $child_rule = $rule->restrict_rule( \@rule_instance, $model, $hpp_model, \%params ) +sub restrict_rule +{ + # get input arguments + my $rr = shift @_; + my $rule_instance = shift @_; + my $model = shift @_; + my $hybrid_model = shift @_; + my $user_params = (@_) ? shift : {}; + + + # Specify default params + my $params = { max_agg => 1e99, + max_stoich => {}, + verbose => 0 + }; + # overwrite defaults with user params + while ( my ($opt,$val) = each %$user_params ) + { $params->{$opt} = $val; } + + + # remember number of reactants and products + my $n_reactants = @{$rr->Reactants}; + my $n_products = @{$rr->Products}; + + + # copy the target reactants and transfer labels from patterns to the copied reactants. + my $matches = []; # holds maps from reactant patterns to (copies of) target SpeciesGraphs + my $reactants = []; # holds (copies of) target SpeciesGraphs + foreach my $match ( @$rule_instance ) + { + # copy the map and target graph (map copy points to the target copy) + my $match_copy = $match->copy_map_and_target(); + # tranfer labels and attributes on the source graph to the target graph + $match_copy->transferLabels(); + # save the map copy and the target copy + push @$matches, $match_copy; + push @$reactants, $match_copy->Target; + } + + + # next, let's collect all the labels in reactant and product patterns + my $temp_labels = {}; + { + my $used_labels = {}; + + foreach my $pattR ( @{$rr->Reactants} ) + { $pattR->gatherLabels( $used_labels ); } + + foreach my $pattP ( @{$rr->Products} ) + { $pattP->gatherLabels( $used_labels ); } + + # assign unique labels to everything that isn't labeled + my $i_label = 0; + foreach my $reactant ( @$reactants ) + { + $i_label += $reactant->assignLabels( $i_label, $temp_labels, $used_labels ); + } + } + + + # TODO: we want to check that reactants can interact here, but compartments aren't yet + # supported in NFsim. So we'll cross this bridge later. --Justin + + + my ( $products ) = $rr->apply_operations( $matches ); + return undef unless ( defined $products ); + + # Check for correct number of product graphs + if ( @$products != $n_products ) + { + # If Molecules are being deleted, it is allowed to have more subgraphs than product patterns + if ( $rr->DeleteMolecules and @$products > $n_products ) + { + if ($params->{verbose}) + { printf "Deleting molecules in Rule %s\n", $rr->Name(); } + } + # Otherwise, the reaction shouldn't happen + else + { + if ($params->{verbose}) + { printf "Rule %s: n_sub (%d)!= n_prod (%d)\n", $rr->Name, @$products, $n_products; } + return undef; + } + } + + # Check and Process Product Graphs + for ( my $ip = 0; $ip < @$products; ++$ip ) + { + my $p = $products->[$ip]; + my $iprod = ($ip < @{$rr->Products}) ? $ip : -1; + + # check for Max Aggregation violations + if ( @{$p->Molecules} > $params->{max_agg} ) + { + #printf "%d molecules exceeds max_agg of %d\n", $#{$p->Molecules}+1, $max_agg; + return undef; + } + + # check for Max Stoichiometry violations + foreach my $key ( keys %{$params->{'max_stoich'}} ) + { + my $max = $params->{'max_stoich'}->{$key}; + next if ($max eq "unlimited"); + if ( $p->stoich($key) > $max ) + { + #printf "Stoichometry of $key in %s exceeds max of %d\n", $p->toString(), $max; + return undef; + } + } + + # Put product graph in canonical order (quasi-canonical for the time being) + if ( my $err = $p->sortLabel() ) + { # mysterious problem + print "WARNING: some problem in sortLabels.\n" + . ">> $err\n" + . ">>", $rr->toString(), "\n"; + return undef; + } + + # Does product match excluded pattern? + if ( $iprod >= 0 ) + { + foreach my $patt_excl ( @{$rr->Pexclude->[$iprod]} ) + { + if ( $patt_excl->isomorphicToSubgraph($p) ) + { + # Abort this reaction + return undef; + } + } + + # Does product match included pattern? Must do so if include patterns are specified. + if ( @{$rr->Pinclude->[$iprod]} ) + { + my $include = 0; + foreach my $patt_incl ( @{$rr->Pinclude->[$iprod]} ) + { + if ( $patt_incl->isomorphicToSubgraph($p) ) + { + $include = 1; + last; + } + } + return undef unless $include; + } + } + } + + + # if reactant is isomorphic to a population graph, then substitute + if ( defined $model->PopulationList ) + { + # first replace reactants + foreach my $reactant ( @$reactants ) + { + # skip reactant if it's not a species! + next unless ( defined $reactant->Species ); + foreach my $pop ( @{$model->PopulationList->List} ) + { + if ( $pop->SpeciesGraph->isomorphicToSubgraph($reactant) ) + { + # replace reactant with population and transfer pattern label (the "Ref", not the "ID") + my $label = $reactant->Label(); + $reactant = $pop->Population->copy(); + $reactant->Label( $label ); + last; + } + } + } + # now products + foreach my $product ( @$products ) + { + foreach my $pop ( @{$model->PopulationList->List} ) + { + if ( $pop->SpeciesGraph->isomorphicToSubgraph($product) ) + { + # replace product with population and transfer pattern label (the "Ref", not the "ID") + my $label = $product->Label(); + $product = $pop->Population->copy(); + $product->Label( $label ); + last; + } + } + } + } + # TODO: if population obscures a molecule rooted local function, we'll need to + # pre-compile the local function. But this can wait until we handle molecule rooted + # observables are implemented in BNG + + # remove unnecessary temporary labels + SpeciesGraph::removeRedundantLabels( $reactants, $products, $temp_labels ); + + # Create expanded rule + my $child_rule = RxnRule::new(); + + # write rule name (remove parantheses around "reverse") + my $name = $rr->Name . '_v' . ((scalar (keys %{$rr->RxnLabels})) + 1); + $name =~ s/\(reverse\)/_rev/g; + + $child_rule->Name( $name ); + $child_rule->Reactants( $reactants ); + $child_rule->Products( $products ); + $child_rule->RateLaw( $rr->RateLaw->copy() ); + $child_rule->TotalRate( $rr->TotalRate ); + $child_rule->Priority( $rr->Priority ); + $child_rule->DeleteMolecules( $rr->DeleteMolecules ); + $child_rule->MoveConnected( $rr->MoveConnected ); + + my $rinclude = []; + my $rexclude = []; + for ( my $ir = 0; $ir < @$reactants; ++$ir ) + { + my $reactant = $reactants->[$ir]; + if ( $reactant->isPopulationType($hybrid_model->MoleculeTypesList) ) + { # no need to recheck include/exclude if reactant is a population + push @$rinclude, []; + push @$rexclude, []; + } + else + { + push @$rinclude, [ map {$_->copy()->relinkCompartments($hybrid_model->CompartmentList)} @{$rr->Rinclude->[$ir]} ]; + push @$rexclude, [ map {$_->copy()->relinkCompartments($hybrid_model->CompartmentList)} @{$rr->Rexclude->[$ir]} ]; + } + } + + my $pinclude = []; + my $pexclude = []; + for ( my $ip = 0; $ip < @$products; ++$ip ) + { + my $product = $products->[$ip]; + + if ( $ip >= @{$rr->Products} or $product->isPopulationType($hybrid_model->MoleculeTypesList) ) + { # no need to recheck include/exclude if product is a population + push @$pinclude, []; + push @$pexclude, []; + } + else + { + push @$pinclude, [ map {$_->copy()->relinkCompartments($hybrid_model->CompartmentList)} @{$rr->Pinclude->[$ip]} ]; + push @$pexclude, [ map {$_->copy()->relinkCompartments($hybrid_model->CompartmentList)} @{$rr->Pexclude->[$ip]} ]; + } + } + + $child_rule->Rinclude( $rinclude ); + $child_rule->Pinclude( $rexclude ); + $child_rule->Rexclude( $pinclude ); + $child_rule->Pexclude( $pexclude ); + + + # gather references + my $rrefs = {}; + for ( my $i_sg = 0; $i_sg < @$reactants; ++$i_sg) + { + my $sg = $reactants->[$i_sg]; + $sg->gatherLabels( $rrefs, $i_sg ); + } + my $prefs = {}; + for ( my $i_sg = 0; $i_sg < @$products; ++$i_sg) + { + my $sg = $products->[$i_sg]; + $sg->gatherLabels( $prefs, $i_sg ); + } + $child_rule->RRefs( $rrefs ); + $child_rule->PRefs( $prefs ); + + + # construct class ID for this child rule + # (et's be a little safe here and use the StringID instead of StringExact) + my $stringID = join '+', (map {$_->toString()} @$reactants); + $stringID .= '->'; + $stringID .= join '+', (map {$_->toString()} @$products[0..$n_products-1]); + if ( @$products > $n_products ) + { + $stringID .= '+' . join( '+', sort (map {$_->toString()} @$products[$n_products..$#$products]) ); + } + $child_rule->StringID( $stringID ); + + + # Find mapping of reactants onto products + if ( my $err = $child_rule->findMap( $hybrid_model->MoleculeTypesList ) ) + { + send_warning( sprintf "Could not find reactant-product correspondence map for exapnded rule %s.", $child_rule->Name ); + return undef; + } + + + # Does child rule include a delete molecule transform? + my $delmol = grep {$_ =~ /\./} @{$child_rule->MolDel}; + if ( $delmol ) + { + unless ( $child_rule->DeleteMolecules ) + { + # set delete molecules flag (NFsim requires this) + $child_rule->DeleteMolecules(1); + if ( @{$rr->MolDel} ) + { # warn user since this may produce conflicts with delete species transforms + send_warning( sprintf "DeleteMolecules flag added to rule %s.", $child_rule->Name ); + } + } + } + + + # TODO: determine if we need to make any changes to handle MultScale + $child_rule->RateLaw->Factor( 1 ); + + # add this child rule to RxnLabels + $rr->RxnLabels->{$stringID} = $child_rule; + + # all done! + return $child_rule; +} + + + +### +### +### + + + +sub factorial +{ + my $n = shift; + if ( $n == 0 ) { return 1; } + else { return $n * factorial( $n - 1 ); } +} + + + +### +### +### + +1; diff --git a/libvcell/vcell_install/bionetgen/Perl2/Rxn.pm b/libvcell/vcell_install/bionetgen/Perl2/Rxn.pm new file mode 100644 index 0000000..a5c0742 --- /dev/null +++ b/libvcell/vcell_install/bionetgen/Perl2/Rxn.pm @@ -0,0 +1,417 @@ +# $Id: Rxn.pm,v 1.9 2007/07/06 04:46:32 faeder Exp $ + +package Rxn; + +# pragmas +#use strict; +#use warnings; +no warnings 'redefine'; + +# Perl Modules +use Class::Struct; +use FindBin; +use lib $FindBin::Bin; + +# BNG Modules +use BNGUtils; +use SpeciesGraph; +use EnergyPattern; + + + +struct Rxn => { + Reactants => '@', # Array of reactant Species + Products => '@', # Array of product Species + RateLaw => 'RateLaw', # Reference to a RateLaw object + StatFactor => '$', # Statistical (multiplicity) factor for multiple rxn pathways + Priority => '$', # Priority of this Rxn (Deprecated?) + RxnRule => '$', # RxnRule that generated this Rxn + RxnRuleArray => '@', # Stores all RxnRules that generate this Rxn (can be more than one) + Index => '$', # Reaction Index for writing network output + InstanceHash => '$', # Keeps track of instances generated from rules. (#John Sekar) +}; + + +sub toString +{ + my $rxn = shift @_; + my $text = @_ ? shift @_ : 0; + my $plist = @_ ? shift @_ : undef; + my $convert_units = @_ ? shift @_ : 1; # convert from intensive to extensive units (true/false) + + my $err; + my $string; + + if ($text) + { # write Reactants and Products as BNGL strings + my @rstrings=(); + my @pstrings=(); + foreach my $r ( @{$rxn->Reactants} ) + { push @rstrings, $r->SpeciesGraph->toString(); } + foreach my $p ( @{$rxn->Products} ) + { push @pstrings, $p->SpeciesGraph->toString(); } + $string = join(' + ', @rstrings) . " -> " . join(' + ', @pstrings); + } + else + { # just write Reactant and Product species indexes + $string = $rxn->stringID(); + } + + $string .= ' '; + + # get the expression for converting intensive units to extensive units (if any) + my $conv_expr = undef; + my $comp_name = undef; + if ($convert_units) + { ($conv_expr, $comp_name, $err) = $rxn->get_intensive_to_extensive_units_conversion($BNGModel::GLOBAL_MODEL); } + + # Write the Ratelaw... + if (defined $rxn->RateLaw) + { $string .= $rxn->RateLaw->toString($rxn->StatFactor, 1, $plist, $conv_expr); } + + # append comments + $string .= " #"; + + # write source RxnRule +# if (defined $rxn->RxnRule) { $string .= $rxn->RxnRule->Name; } + if (defined $rxn->RxnRule) + { + my $i = 0; + foreach my $rr (@{$rxn->RxnRuleArray}){ + if ($i > 0) { $string .= "," } + $string .= $rr->Name; + $i++; + } + } + + # write unit conversions + if (defined $conv_expr) + { $string .= " unit_conversion=" . $conv_expr->toString($plist); } + + return $string; +} + + +### +### +### + + +sub get_intensive_to_extensive_units_conversion +# ($vol_expr, $comp_name, $err) = $rxn->get_intensive_to_extensive_units_conversion($model) +# Get expression that converts intrinsic rate constants to extrinsic units. +# Returns undefined if the conversion expression is '1'. +# +# for bi-molecular reactions, the reaction compartment is the 3-D volume [V] +# unless all reactants are at a 2-D surface [S]. +# +# rxn type adjustment +# ---------------------------------------------------- +# S none +# V none +# S + S /S +# S + V /V +# V + V /V +# S + S + S /S/S +# S + S + V /S/V +# S + V + V /V/V +# V + V + V /V/V etc... +# 0 -> S S +# 0 -> V V +{ + my ($rxn, $model) = @_; + + my $err; + my $conv_expr = undef; + my $comp_name = undef; + + # get all the defined compartments + my @reactant_compartments = grep {defined $_} (map {$_->SpeciesGraph->Compartment} @{$rxn->Reactants}); + my @product_compartments = grep {defined $_} (map {$_->SpeciesGraph->Compartment} @{$rxn->Products}); + + # return undefined volume expr if there are no compartments + if ( @reactant_compartments ) + { # order >=1 reactions + # divide into surfaces and volumes + my @surfaces = ( grep {$_->SpatialDimensions==2} @reactant_compartments ); + my @volumes = ( grep {$_->SpatialDimensions==3} @reactant_compartments ); + + if (@surfaces) + { # TODO: check for consistency for both + $comp_name = @surfaces[0]->Name; + } + elsif (@volumes) + { + $comp_name = @volumes[0]->Name; + } + # Pick and toss an anchor reactant. If there's a surface reactant, toss it. + # Otherwise toss a volume. + (@surfaces) ? shift @surfaces : shift @volumes; + + # if there are surfaces or volumes remaining, we need to define a volume expression + if ( @surfaces or @volumes ) + { # order >=2 reactions + my $number_per_quantity; + if ( exists $model->Options->{NumberPerQuantityUnit} ) + { $number_per_quantity = $model->Options->{NumberPerQuantityUnit}; } + + # construct the volume expression + my @terms = map {$_->Size} (@surfaces, @volumes); + if (defined $number_per_quantity) + { @terms = map { Expression::operate('*', [$number_per_quantity, $_], $model->ParamList) } @terms; } + + $conv_expr = Expression::operate('/', [1, @terms], $model->ParamList); + unless ( defined $conv_expr ) + { $err = "RateLaw::get_intensive_to_extensive_units_conversion() - Some problem defining unit conversion expression."; } + } + } + elsif ( @product_compartments>0 ) + { # zero-order reactions + + # check if products are in the same compartment + my $consistent = 1; + my $comp1 = $product_compartments[0]; + foreach my $comp2 ( @product_compartments[1..$#product_compartments] ) + { + unless ($comp1 == $comp2) + { + $consistent = 0; + last; + } + } + if ($consistent) + { # construct the volume expression + $conv_expr = $comp1->Size; + $comp_name = $comp1->Name; + } + else + { send_warning("BioNetGen doesn't know how to handle zero-order synthesis of products in multiple compartments."); } + } + elsif ( @product_compartments=0 ) + { # zero-order synthesis products that do not have a compartment + $err = "BioNetGen cannot complete the zero-order synthesis of products if a compartment is not specified."; + } + + # return the expression (possibly undefined) and the error msg (if any). + return $conv_expr, $comp_name, $err; +} + + + +### +### +### + + +sub getCVodeName +{ + my $rxn = shift; + return 'NV_Ith_S(ratelaws,' . $rxn->Index . ')' +} + + +### +### +### + + +sub getMatlabName +{ + my $rxn = shift; + my $offset = 1; + return 'ratelaws(' . ($rxn->Index + $offset) . ')'; +} + + +### +### +### + +sub getCVodeRate +{ + my $rxn = shift @_; + my $plist = shift @_; + my $convert_units = @_ ? shift @_ : 1; # convert from intensive to extensive units (true/false) + + + # get the expression for converting intensive units to extensive units (if any) + my $conv_expr = undef; + my $comp_name = undef; + if ($convert_units) + { ($conv_expr, $comp_name, $err) = $rxn->get_intensive_to_extensive_units_conversion($BNGModel::GLOBAL_MODEL); } + + # get reference to RxnRule RRef hash (TODO: may be obsolete) + my $rrefs = undef; + if ( $rxn->RxnRule ) + { $rrefs = $rxn->RxnRule->RRefs; } + # get ratelaw string + return $rxn->RateLaw->toCVodeString( $rxn->StatFactor, $rxn->Reactants, $rrefs, $plist, $conv_expr ); +} + + +### +### +### + + +sub getMatlabRate +{ + my $rxn = shift @_; + my $plist = shift @_; + my $convert_units = @_ ? shift @_ : 1; # convert from intensive to extensive units (true/false) + + # get the expression for converting intensive units to extensive units (if any) + my $conv_expr = undef; + my $comp_name = undef; + if ($convert_units) + { ($conv_expr, $comp_name, $err) = $rxn->get_intensive_to_extensive_units_conversion($BNGModel::GLOBAL_MODEL); } + + # get reference to RxnRule RRef hash + my $rrefs = undef; + if ( $rxn->RxnRule ) + { $rrefs = $rxn->RxnRule->RRefs; } + # get ratelaw string + return $rxn->RateLaw->toMatlabString( $rxn->StatFactor, $rxn->Reactants, $rrefs, $plist, $conv_expr ); +} + + +### +### +### + +sub getMDLrxn +{ + my $rxn = shift; + my $plist = shift; + my $iscomp = shift; + my $py_reactions = shift; + my $string = " "; + my $py_string = ""; + + my $mcomp = undef; + my %orient; + + if ($iscomp){ + foreach (@{$rxn->Reactants}){ + if ($_->SpeciesGraph->Compartment->SpatialDimensions == 2){ + $mcomp = $_->SpeciesGraph->Compartment; + last; + } + } + } + + if (defined $mcomp){ + foreach (@{$rxn->Reactants}){ + my $scomp = $_->SpeciesGraph->Compartment; + if ($scomp->SpatialDimensions == 2){ + $orient{$_->Index} = "'"; + } + if ($scomp->SpatialDimensions == 3){ + $orient{$_->Index} = ($scomp->Outside) ? ($mcomp == $scomp->Outside ? "," : "'") : "'" ; + } + + foreach (@{$rxn->Products}){ + my $scomp = $_->SpeciesGraph->Compartment; + if ($scomp->SpatialDimensions == 2){ + $orient{$_->Index} = "'"; + } + if ($scomp->SpatialDimensions == 3){ + $orient{$_->Index} = ($scomp->Outside) ? ($mcomp == $scomp->Outside ? "," : "'") : "'" ; + } + } + } + } + else{ + foreach (@{$rxn->Reactants}){ + $orient{$_->Index} = ""; + } + foreach (@{$rxn->Products}){ + $orient{$_->Index} = ""; + } + } + + my $reactant_expr = join " + ", map {"s".$_->Index.$orient{$_->Index}} @{$rxn->Reactants}; + my $product_expr = join " + ", map {"s".$_->Index.$orient{$_->Index}} @{$rxn->Products}; + + $string .= $reactant_expr; + $string .= " -> "; + $string .= $product_expr; + + $py_string .= "{\"reactants\":\"".$reactant_expr."\","; + $py_string .= "\"products\":\"".$product_expr."\","; + + + # Write the Ratelaw... + # First prcoess reaction multipliers (statistical factor, compartment volumes, etc) + my $err = undef; + + #my $rxn_mult_temp=""; + #if (scalar @{$rxn->Reactants} >1){ + #my $i = 0; + #foreach (@{$rxn->Reactants}){ + #$i = 1 if ($_->SpeciesGraph->Compartment->SpatialDimensions == 3); + #} + #$rxn_mult_temp = ($i == 1) ? "*Nav" : "/rxn_layer_t"; + #} + + + my $rxn_mult = undef; + + # get ratelaw string + #$string .= sprintf(" [%s$rxn_mult_temp]",$rxn->RateLaw->toString( $rxn_mult, 1, $plist )); + my $rate_expr = sprintf("%s",$rxn->RateLaw->toString($rxn->StatFactor, 1, $plist)); + $string .= " [".$rate_expr."]"; + $py_string .= "\"fwd_rate\":\"".$rate_expr."\"}"; + push (@{$py_reactions}, $py_string); + if ($rxn->RxnRule) + { $string .= " /* BNG ".$rxn->RxnRule->Name." */" ; } + + return $string; + +} + + +# Used to compare whether reactions are identical +# (only in terms of species involved) +sub stringID +{ + my $rxn = shift; + my $string = ''; + + # Prior to 2.1.7, a reaction with zero reactants or zero products produced an + # empty string for the respective field. Network2 does not recognize the null + # string, leading to a parsing error. To resolve this issue, a null reactant (or product) + # indicated by the index "0" will be output for the reactant (resp. product) field + # if a reaction has zero reactants (or products). --Justin, 29oct2010 + + # get reactant indices + my @rstrings=(); + if ( @{$rxn->Reactants} ) + { foreach my $r (@{$rxn->Reactants}) { push @rstrings, $r->Index; } } + else + { push @rstrings, "0"; } + + # get product indices + my @pstrings=(); + if ( @{$rxn->Products} ) + { foreach my $p (@{$rxn->Products}) { push @pstrings, $p->Index; }; } + else + { push @pstrings, "0"; } + + # sort reactants and products (if ratelaw is elementary or zero-order) + my $type= $rxn->RateLaw->Type; + if ( $type eq "Ele" ) + { # don't sort MM, Sat, or Hill... TODO: sort Function ratelaws? (since local context is already evaluated) + @rstrings = sort {$a<=>$b} @rstrings; + @pstrings = sort {$a<=>$b} @pstrings; + } + + $string .= join(',', @rstrings) . " " . join(',', @pstrings); + return $string; +} + +### +### +### + +1; diff --git a/libvcell/vcell_install/bionetgen/Perl2/RxnList.pm b/libvcell/vcell_install/bionetgen/Perl2/RxnList.pm new file mode 100644 index 0000000..40fcbe6 --- /dev/null +++ b/libvcell/vcell_install/bionetgen/Perl2/RxnList.pm @@ -0,0 +1,550 @@ +# $Id: RxnList.pm,v 1.6 2006/09/28 02:21:03 faeder Exp $ + +package RxnList; + +# pragmas +use strict; +use warnings; +no warnings 'redefine'; + +# Perl Modules +use Class::Struct; +use FindBin; +use lib $FindBin::Bin; + +# BNG Modules +use Rxn; +use SpeciesList; +use BNGUtils; + +# This class manages a list of Rxn objects +struct RxnList => { + Array => '@', + Hash => '%', + SpeciesList => 'SpeciesList', + AsProduct => '%' # Number of times a species appears as product, + # key is pointer to Species +}; + + +### +### +### + + +# reset the rxn hash (i.e. forget about rxns that are in the array) +sub resetHash +{ + my $rlist = shift; + undef %{ $rlist->Hash }; +} + + +# get the size of the rxn list +sub size +{ + my $rlist = shift @_; + return scalar @{$rlist->Array}; +} + + +### +### +### + + + +# Add a reaction to the list. +# Returns the number of added reactions. +sub add +{ + my $rlist = shift @_; + my $rxn = shift @_; + my $add_zero = @_ ? shift @_ : 0; + my $plist = @_ ? shift @_ : undef; + + my $n_add = 0; + my $add_rxn = 1; + + # Modify the string returned by this call to affect when reactions are combined. + my $rstring = $rxn->stringID(); + my ($r, $p) = split ' ', $rstring; + + # Check for identical reactants and products + if ( $r eq $p ) + { # null rxn, don't add to the list + $add_rxn = 0; + } + elsif ( exists $rlist->Hash->{$rstring} ) + { + foreach my $rxn2 ( @{ $rlist->Hash->{$rstring} } ) + { + # NOTE: This algorithm guarantees that all rxns on list have same priority. + if ( $rxn->Priority == $rxn2->Priority ) + { + # Reaction with same rate law as previous reaction is combined with it + # TODO: this may be obsolete after implementing ratelaw hashing.. + if ( RateLaw::equivalent($rxn->RateLaw, $rxn2->RateLaw, $plist) ) + { + $rxn2->StatFactor( $rxn2->StatFactor + $rxn->StatFactor ); + $add_rxn = 0; + + # For write_autos output (see BNG2.pl user options) - John Sekar + if(defined $BNGModel::GLOBAL_MODEL->Params->{'write_autos'}==1) + { + if($BNGModel::GLOBAL_MODEL->Params->{'write_autos'}==1) + { + ++$rxn2->InstanceHash->{$rxn2->RxnRule->Name}; + } + } + # Check if different rules are generating the same rxn + if ($rxn->RxnRule != $rxn2->RxnRule){ + # Add ref to new RxnRule to array of RxnRules + push @{$rxn2->RxnRuleArray}, @{$rxn->RxnRuleArray}; + # Send a warning that a duplicate reaction was generated from a different rule + my $msg = "Duplicate of rxn " . $rxn2->Index . " detected. Rules generating this rxn are "; + my $i = 0; + foreach $r (@{$rxn2->RxnRuleArray}){ + if ($i > 0){ $msg .= ", "; } + $msg .= $r->Name; + if ($i == $#{$rxn2->RxnRuleArray}){ $msg .= "."; } + $i++; + } + send_warning($msg); + } + + # Need to delete reaction and ratelaw? + # (if the ratelaws references are different and the rules are the same, + # then we can safely delete the extra Ratelaw copy. This is useful + # for energy BNG where we derive new ratelaws from general rates, but often + # the same derived law works for many reactions. Deleting redundant derived laws + # allows us to save space.) + if ( ($rxn->RateLaw != $rxn2->RateLaw) and ($rxn->RxnRule == $rxn2->RxnRule) ) + { + if ( defined $plist ) + { + # delete parameters associated with this ratelaw + foreach my $const ( @{$rxn->RateLaw->Constants} ) + { $plist->deleteParam( $const ); } + } + + # undefine the ratelaw + undef %{$rxn->RateLaw}; + + # set this rxn ratelaw equal to rxn2 ratelaw + # (in practice, we don't need rxn anymore, so this is moot) + $rxn->RateLaw( $rxn2->RateLaw ); + } + + # Exit from loop since rxn is now handled. + last; + } + } + elsif ( $rxn->Priority < $rxn2->Priority ) + { + # New reaction has lower priority so it's not added and we're done + $add_rxn = 0; + last; + } + elsif ( $rxn->Priority > $rxn2->Priority ) + { + # New reaction has higher priority, causing previous reaction to be deleted + # NOTE: All reactions with the lower priority will be deleted by looping over $rxn2 + # Find and delete old entry from Array + $rlist->remove($rxn2); + --$n_add; + } + } # END loop over previous reactions + } + + # Add new entry + if ($add_rxn) + { + # For write_autos output (see BNG2.pl user options) - John Sekar + if (defined $BNGModel::GLOBAL_MODEL->Params->{'write_autos'}==1) + { + if($BNGModel::GLOBAL_MODEL->Params->{'write_autos'}==1) + { + ++$rxn->InstanceHash->{$rxn->RxnRule->Name}; + } + } + + push @{ $rlist->Array }, $rxn; + $rxn->Index(scalar @{$rlist->Array}); + push @{ $rlist->Hash->{$rstring} }, $rxn; + foreach my $spec ( @{$rxn->Products} ) + { ++($rlist->AsProduct->{$spec}); } + ++$n_add; + } + + return ($n_add); +} + + +### +### +### + + +# remove a reaction from the list +sub remove +{ + my $rlist = shift; + my $rxn = shift; + + # Remove entry from Array + foreach my $i ( 0 .. $#{$rlist->Array} ) + { + if ( $rxn == $rlist->Array->[$i] ) + { + printf "Deleting rxn %s\n", $rxn->toString(); + splice( @{$rlist->Array}, $i, 1 ); + last; + } + } + + # Remove entry from Hash + my $harray = $rlist->Hash->{ $rxn->stringID() }; + foreach my $i ( 0 .. $#{$harray} ) + { + if ( $rxn == $harray->[$i] ) + { + #printf "Deleting rxn from hash %s\n", $rxn->toString(); + splice( @$harray, $i, 1 ); + last; + } + } + + # Delete species that depend only on this reaction for production + # Species with non-zero concentration must exist + # Species with zero concentration must appear as product in at least one reaction + # *phash = $rlist->AsProduct; + # for my $spec ( @{ $rxn->Products } ) { + # if ( ( --$phash{$spec} ) == 0 ) { + # + # # Remove species from SpeciesList if it has zero concentration + # $rlist->SpeciesList->remove($spec); + # } + # } + + return; +} + + +### +### +### + + +# read a reaction from a string and add it to the list +sub readString +{ + my $rlist = shift; + my $string = shift; + my $slist = shift; + my $plist = shift; + + my @tokens = split( ' ', $string ); + my $rxn = Rxn->new(); + my $err; + + my $nspec = scalar @{$slist->Array}; + + # Check if token is an index + if ( $tokens[0] =~ /^\d+$/ ) { + my $index = shift @tokens; # This index will be ignored + } + + # Next token is list of reactant indices + my @ptrs; + if (@tokens) + { + @ptrs = (); + my @inds = split( ',', shift(@tokens) ); + foreach my $index (@inds) + { + # check for bad index + if ( $index < 0 || ($index > $nspec) ) + { + return ("Index $index to species in reaction out of range"); + } + + # NOTE: zero is the null species, so ignore indices less than 1 + unless ( $index==0 ) + { push @ptrs, $slist->Array->[$index - 1]; } + } + } + else + { + return ("Incomplete reactantion at reactants"); + } + $rxn->Reactants( [@ptrs] ); + + + # Next token is list of product indices + if (@tokens) + { + @ptrs = (); + my @inds = split( ',', shift(@tokens) ); + foreach my $index (@inds) + { + # check for bad index + if ( $index < 0 || ($index > $nspec) ) + { + return ("Index $index to species in reaction out of range"); + } + + # NOTE: zero is the null species, so ignore indices less than 1 + unless ( $index==0 ) + { push @ptrs, $slist->Array->[$index - 1]; } + + } + } + else + { + return ( "Incomplete reaction at products" ); + } + $rxn->Products( [@ptrs] ); + + # Next token is rate law + # This will create a separate RateLaw object for each reaction. When reaction + # rules are used to generate Rxns, only one RateLaw is used per RxnRule. + # Information about which rule created the reacion is lost because of this. Also, + # the statistical factor gets folded into the rate law rather than being part of the + # reaction, since it is not possible to separate the contributions to the overall + # weight. + my $rl; + if (@tokens) + { + my $rlstring = join( ' ', @tokens ); + + #print "rlstring=$rlstring\n"; + ( $rl, $err ) = RateLaw::newRateLawNet( \$rlstring, $plist ); + if ($err) { return ($err); } + } + else + { + return ("Incomplete reaction at rate law"); + } + $rxn->RateLaw($rl); + + # Set remaining attributes of rxn + $rxn->StatFactor(1); + $rxn->Priority(0); + + # Create new Rxn entry in RxnList + my $n_add = $rlist->add($rxn,0,$plist); + + return (''); +} + + +### +### +### + + +# write reaction list to a string formatted for a BNGL .NET output file +sub writeBNGL +{ + my $rlist = shift @_; + my $params = @_ ? shift @_ : { 'TextReaction'=>0, 'convert_intensive_to_extensive_units'=>1 }; + my $plist = @_ ? shift : undef; + + my $out = ''; + + # write non-text reactions + $out .= "begin reactions\n"; + my $irxn = 1; + foreach my $rxn ( @{ $rlist->Array } ) + { + $out .= sprintf "%5d %s\n", $irxn, $rxn->toString( 0, $plist, $params->{'convert_intensive_to_extensive_units'} ); + ++$irxn; + } + $out .= "end reactions\n"; + + # write reactions as text? + my $text = $params->{TextReaction}; + + if ($text){ + $out .= "begin reactions_text\n"; + my $irxn = 1; + foreach my $rxn ( @{ $rlist->Array } ) + { + $out .= sprintf "%5d %s\n", $irxn, $rxn->toString( $text, $plist, $params->{'convert_intensive_to_extensive_units'} ); + ++$irxn; + } + $out .= "end reactions_text\n"; + } + + return $out; +} + + +### +### +### + +sub writeMDL +{ + my $rlist = shift; + my $plist = shift; + my $iscomp = shift; + my $py_reactions = shift; + + my $string = "DEFINE_REACTIONS\n{\n"; + foreach my $rxn (@{$rlist->Array}) + { + $string .= $rxn->getMDLrxn($plist, $iscomp, $py_reactions)."\n"; + } + $string .= "}"; + return $string; +} + + +# print rxns to a file +sub print +{ + my $rlist = shift; + my $fh = shift; + my $i_start = (@_) ? shift : 0; + + print $fh "begin reactions\n"; + my $i = $i_start; + while ( $i < @{$rlist->Array} ) + { + my $rxn = $rlist->Array->[$i]; + printf $fh "%5d %s\n", $i-$i_start+1, $rxn->toString(); + ++$i; + } + print $fh "end reactions\n"; + return (''); +} + + +### +### +### + + +# index reactions. BNG doesn't use this, but it's useful for writing +# vector output +sub updateIndex +{ + my $rlist = shift; + my $plist = (@_) ? shift : undef; + + my $err; + my $n_rxns = 0; + foreach my $rxn ( @{$rlist->Array} ) + { + $rxn->Index( $n_rxns ); + ++$n_rxns; + } + + return $err; +} + + +### +### +### + + +# return a string with CVode reaction rate defintions for +# each reaction in the list. +sub getCVodeRateDefs +{ + my $rlist = shift @_; + my $plist = @_ ? shift @_ : undef; + + # expression definition string + my $rate_defs = ''; + # to hold errors.. + my $err; + # size of the indent + my $indent = ' '; + + # loop through reactions and generate rate desfinitions + foreach my $rxn ( @{ $rlist->Array } ) + { + $rate_defs .= $indent . $rxn->getCVodeName() . ' = ' . $rxn->getCVodeRate($plist) . ";\n"; + } + + return ($rate_defs, $err); +} + + +### +### +### + + +# return a string with Matlab reaction rate defintions for +# each reaction in the list. +sub getMatlabRateDefs +{ + my $rlist = shift @_; + my $plist = @_ ? shift @_ : undef; + + # expression definition string + my $rate_defs = ''; + # to hold errors.. + my $err; + # size of the indent + my $indent = ' '; + + # loop through reactions and generate rate desfinitions + my $i_rxn = 1; + foreach my $rxn ( @{ $rlist->Array } ) + { + $rate_defs .= $indent . $rxn->getMatlabName() . ' = ' . $rxn->getMatlabRate($plist) . ";\n"; + ++$i_rxn; + } + + return ($rate_defs, $err); +} + + +### +### +### + + +# construct a sparsely encoded stoichiometry matrix +sub calcStoichMatrix +{ + my $rlist = shift; + my $stoich_hash = shift; + + my $err; + + my @fluxes = (); + my $i_rxn = 1; + foreach my $rxn ( @{ $rlist->Array } ) + { + # Each reactant contributes a -1 + foreach my $reactant ( @{ $rxn->Reactants } ) + { --( $stoich_hash->{ $reactant->Index }{$i_rxn} ); } + + # Each product contributes a +1 + foreach my $product ( @{ $rxn->Products } ) + { ++( $stoich_hash->{ $product->Index }{$i_rxn} ); } + + ++$i_rxn; + } + + return ($err); +} + + +### +### +### + + +# Need join function to merge two lists. Could make use of reaction +# precedence here if the rate law was suppressed from the string used to +# compare reactions + +1; diff --git a/libvcell/vcell_install/bionetgen/Perl2/RxnRule.pm b/libvcell/vcell_install/bionetgen/Perl2/RxnRule.pm new file mode 100644 index 0000000..72becf5 --- /dev/null +++ b/libvcell/vcell_install/bionetgen/Perl2/RxnRule.pm @@ -0,0 +1,4280 @@ +package RxnRule; + +# pragmas +use strict; +use warnings; +no warnings 'redefine'; + +# Perl Modules +use Class::Struct; +# consider using for reference address comparison? +#use Scalar::Util 'refaddr'; + +# BNG Modules +use BNGUtils; +use SpeciesGraph; +use Species; +use RateLaw; +use EnergyPattern; +use SpeciesList; +use MoleculeTypesList; +use RxnList; +use CartesianProduct; +use RefineRule; + + + +# TODO: implement TotalRate feature for Network simulations +# (currently implemented only for XML network-free output) +# --Justin 2dec2010 + +struct RxnRule => +{ + Name => '$', # Name of rule + + Reactants => '@', # Arrays of SpeciesGraphs + Products => '@', # Arrays of SpeciesGraphs + + Rmatches => '@', # Array of Maps onto SpeciesGraphs selected by Reactants SpeciesGraphs + + Rinclude => '@', # Array of patterns to use as context for selecting reactants + Pinclude => '@', # Array of patterns to use as context for selecting products + Rexclude => '@', # Array of patterns to exclude from reactant matches + Pexclude => '@', # Array of patterns to exclude from products + + MapF => '%', # Map from reactants to products 'rP.rM.rC' -> 'pP.pM.pC' + MapR => '%', # Map from products to reactants 'pP.pM.pC' -> 'rP.rM.rC' + + RateLaw => 'RateLaw', # RateLaw + TotalRate => '$', # indicates whether the ratelaws corresponding to this rule define a TotalRate (1) + # or a PerSite rate (default=0) + + Priority => '$', + MultScale => '$', # Factor by which to scale multiplicity to account for symmetry in rule + + RuleInstances => 'CartesianProduct', # object that iterates through instances of the reaction rule + + # The operations performed by the rule + EdgeAdd => '@', + EdgeDel => '@', + MolAdd => '@', + MolDel => '@', + CompStateChange => '@', + ChangeCompartment => '@', + + RRefs => '%', # Refs to objects on reactants side of rule + PRefs => '%', # Refs + + Direction => '$', # direction of rule: forward=1, reverse=-1 + + # operation modifiers + DeleteMolecules => '$', # If True, deleting a molecule in a species will remove only that molecule. + # Default is unset, and behavior of deletion is determined automatically. + MoveConnected => '$', # If True, transporting a molecule in a species will move all molecules + # connected to the first molecule by a path contained in the same compartment. + ReactionCenter => '@', # array of reaction centers for each reactant pattern in RxnRule --justin + RxnLabels => '%', # track canonical reaction labels to eliminate reduncant reactions + + StringID => '$' +}; + + +### +### +### + + +# create copy of a reaction rule +sub copy +{ + my $rr = shift @_; + + my $rr_copy = RxnRule::new(); + $rr_copy->Name( $rr->Name ); + + @{$rr_copy->Reactants} = map {$_->copy()} @{$rr->Reactants}; + @{$rr_copy->Products} = map {$_->copy()} @{$rr->Products}; + + my $ir = 0; + while ( $ir < @{$rr->Reactants} ) + { + push @{$rr_copy->Rinclude}, [ map {$_->copy()} @{$rr->Rinclude->[$ir]} ]; + push @{$rr_copy->Rexclude}, [ map {$_->copy()} @{$rr->Rexclude->[$ir]} ]; + ++$ir; + } + + my $ip = 0; + while ( $ip < @{$rr->Products} ) + { + push @{$rr_copy->Pinclude}, [ map {$_->copy()} @{$rr->Pinclude->[$ip]} ]; + push @{$rr_copy->Pexclude}, [ map {$_->copy()} @{$rr->Pexclude->[$ip]} ]; + ++$ip; + } + + @{$rr_copy->Rmatches} = map { [@{$_}] } @{$rr->Rmatches}; + + %{$rr_copy->MapF} = %{$rr->MapF}; + %{$rr_copy->MapR} = %{$rr->MapR}; + + $rr_copy->RateLaw( $rr->RateLaw->copy() ) if ( defined $rr->RateLaw ); + + $rr_copy->TotalRate( $rr->TotalRate ); + $rr_copy->Priority( $rr->Priority ); + $rr_copy->MultScale( $rr->MultScale ); + + if ( defined $rr->RuleInstances ) + { + $rr_copy->RuleInstances( $rr_copy->RuleInstances->copy() ); + $rr_copy->RuleInstances->Lists( [@{$rr_copy->Rmatches}] ); + } + + @{$rr_copy->EdgeAdd} = map { [@$_] } @{$rr->EdgeAdd}; + @{$rr_copy->EdgeDel} = map { [@$_] } @{$rr->EdgeDel}; + @{$rr_copy->MolAdd} = map { [@$_] } @{$rr->MolAdd}; + @{$rr_copy->MolDel} = @{$rr->MolDel}; + @{$rr_copy->CompStateChange} = map { [@$_] } @{$rr->CompStateChange}; + @{$rr_copy->ChangeCompartment} = map { [@$_] } @{$rr->ChangeCompartment}; + + %{$rr_copy->RRefs} = %{$rr->RRefs}; + %{$rr_copy->PRefs} = %{$rr->PRefs}; + + $rr_copy->Direction( $rr->Direction ); + + $rr_copy->DeleteMolecules( $rr->DeleteMolecules ); + $rr_copy->MoveConnected( $rr->MoveConnected ); + + @{$rr_copy->ReactionCenter} = @{$rr->ReactionCenter}; + %{$rr_copy->RxnLabels} = %{$rr->RxnLabels}; + + $rr_copy->StringID( $rr->StringID ); + + return $rr_copy; +} + + + +### +### +### + + +sub resetLabels +{ + my $rr = shift; + + %{$rr->RxnLabels} = (); + $rr->StringID( undef ); +} + + + +### +### +### + + + +sub newRxnRule +{ + my $string = shift @_; + my $model = shift @_; + my $linenum = @_ ? shift @_ : "?"; + + my ( $err, $sep, $reversible ); + my $name; + + my $DeleteMolecules = 0; + my $MoveConnected = 0; + my $TotalRate = 0; + + # get parameter list, compartment list and molecule type list + my $plist = $model->ParamList; + my $clist = $model->CompartmentList; + my $mtlist = $model->MoleculeTypesList; + + # Remove leading whitespace + $string =~ s/^\s*//; + + # save original text of rule for displaying warnings + (my $rule_text = $string) =~ s/\s+/ /g; + + # Check for a label at the beginning of the string + if ( $string =~ s/^([\w\s]*\w)\s*:\s*// ) + { + $name = $1; + + # Check for whitespace + if ( $1 =~ /\s/ ) + { + BNGUtils::line_error("Reaction rule label '$name' contains white space. This is deprecated (BioNetGen >= 2.2.3).", $linenum); + } + + # Check for a leading number + if ( $1 =~ /^\d/ ) + { + BNGUtils::line_error("Reaction rule label '$name' begins with a number.", $linenum); + } + } + elsif ( $string =~ /^0\s*(\+|->|<->)/ ) + { # We found a numerical token that appears to be a species pattern (perhaps the null pattern?). + # Don't strip this token! + } + elsif ( $string =~ s/^(\d+)\s+// ) + { # We found a numerical token that appears to be a Reaction Rule index. + # Strip the index and assign it as the name. + $name = $1; + } + + # read reactant patterns + my @reac = (); + my %labels = (); + my %rrefs = (); + my %prefs = (); + $sep = '^\s*[+]\s*|^\s*()\s*'; # "+" or "->" or "<->" + my $g; + my $ipatt = -1; + + # Parse Reactant Patterns + while ($string) + { + $g = SpeciesGraph->new(); + $err = $g->readString( \$string, $clist, 0, $sep, $mtlist ); + if ($err) { return [], $err; } + + # warn about deprecated '$' + if ($g->Fixed) + { + my $msg = "Fixing reactant quantity in reaction rule with '\$' syntax is deprecated (BioNetGen >= 2.2.3)."; + BNGUtils::line_warning($msg, $linenum); + } + + unless ( $g->isNull() ) + { + # increment pattern count! + ++$ipatt; + + # Check Labels for this Reactant: + my $label = $g->Label; + if ( defined $label and $label ne '' ) + { + if ( exists $labels{ $label } ) + { return [], "Repeated label '$label' in reactants of reaction rule"; } + $labels{ $label } = "RP"; + $rrefs{ $label } = $ipatt; + } + + # Checking Molecules... + my $imol = -1; + foreach my $mol ( @{$g->Molecules} ) + { + ++$imol; + my $label = $mol->Label; + if ( defined $label ) + { + if ( exists $labels{ $label } ) { return [], "Repeated label '$label' in reactants of reactant rule"; } + $labels{ $label } = "RM"; + $rrefs{ $label } = join '.', ($ipatt, $imol); + } + my $icomp = -1; + + # Checking Components... + for my $comp ( @{ $mol->Components } ) + { + ++$icomp; + $label = $comp->Label; + if ( defined $label ) + { + if ( exists $labels{ $label } ) { return [], "Repeated label '$label' in reactants of reaction rule"; } + $labels{ $label } = "RC"; + $rrefs{ $label } = join '.', ($ipatt, $imol, $icomp); + } + } + } + + # Save this reactant + push @reac, $g; + } + + # Find next separator (some problem with string if there is no separator) + unless ( $string =~ s/$sep// ) { + return ( [], "Invalid syntax in reaction rule: $string" ); + } + + # If the arrow operator was the next separator, then it's captured in $1 + if ($1) + { # Check if this reaction is reversible + $reversible = ( $1 eq "<->" ) ? 1 : 0; + # We're done with Reactants, so exit this loop + last; + } + } + + # Read Product Patterns + my @prod = (); + $sep = '^\s*([+])\s*|^\s+'; # "+" or " " + $ipatt = -1; + while ($string) + { + my $g = SpeciesGraph->new(); + $err = $g->readString( \$string, $clist, 0, $sep, $mtlist ); + if ($err) { return [], $err; } + + # warn about deprecated '$' + if ($g->Fixed) + { + my $msg = "Fixing product quantity in reaction rule with '\$' syntax is deprecated (BioNetGen >= 2.2.3)."; + BNGUtils::line_warning($msg, $linenum); + } + + unless ( $g->isNull() ) + { + ++$ipatt; + # Checking Labels for this Species.. + my $label = $g->Label; + if ( defined $label and $label ne '' ) + { + if ( exists $labels{ $label } ) + { + if ( $labels{ $label } eq 'RP' ) + { # found matching label in reactants + $labels{ $label } = "found"; + } + elsif ( $labels{ $label } =~ /^(RM|RC)$/ ) + { # found matching label in reactants, but wrong object type + return [], "Label '$label' refers to incompatible objects in the reactants and products of rule"; + } + elsif ( $labels{ $g->Label } =~ /^(found|PP|PM|PC)$/ ) + { # label was already matched, this must be a duplicate! + return [], "Repeated label '$label' in products of reaction rule"; + } + } + else + { # this label was not found among the reactants + $labels{ $label } = 'PP' + } + $prefs{ $label } = $ipatt; + } + + # Checking Molecules... (verify correspondence and uniqueness!) + my $imol = -1; + foreach my $mol ( @{ $g->Molecules } ) + { + ++$imol; + my $label = $mol->Label; + if ( defined $label and $label ne '' ) + { + if ( exists $labels{ $label } ) + { + if ( $labels{ $label } eq 'RM' ) + { # found matching label in reactants + $labels{ $label } = "found"; + } + elsif ( $labels{ $g->Label } =~ /^(RP|RC)$/ ) + { # found matching label in reactants, but wrong object type + return [], "Label '$label' refers to incompatible objects in the reactants and products of rule"; + } + elsif ( $labels{ $g->Label } =~ /^(found|PP|PM|PC)$/ ) + { # label was already matched, this must be a duplicate! + return [], "Repeated label '$label' in products of reaction rule"; + } + } + else + { # this label was not found among the reactants + $labels{ $label } = 'PM' + } + $prefs{$label} = join '.', ($ipatt, $imol); + } + + # Checking Components... + my $icomp = -1; + for my $comp ( @{ $mol->Components } ) + { + ++$icomp; + $label = $comp->Label; + + #print "label=$label\n"; + if ( defined $label and $label ne '' ) + { + if ( exists $labels{ $label } ) + { + if ( $labels{ $label } eq 'RC' ) + { # found matching label in reactants + $labels{ $label } = "found"; + } + elsif ( $labels{ $g->Label } =~ /^(RP|RM)$/ ) + { # found matching label in reactants, but wrong object type + return [], "Label '$label' refers to incompatible objects in the reactants and products of rule"; + } + elsif ( $labels{ $g->Label } =~ /^(found|PP|PM|PC)$/ ) + { # label was already matched, this must be a duplicate! + return [], "Repeated label '$label' in products of reaction rule"; + } + } + else + { # this label was not found among the reactants + $labels{ $label } = 'PC'; + } + $prefs{$label} = join '.', ($ipatt, $imol, $icomp); + } + } + } + + # Save this Product pattern + push @prod, $g; + } + + # Check for next separator (store a "+" separator in $1) + $string =~ s/$sep//; + # See if there's more Products to parse.. + last unless $1; + } + + + # Check for labels found in Reactants but not Products and vice versa... + while ( my ($label, $resolution) = each %labels ) + { + if ($resolution =~ /^(RM|RC)$/ ) + { + my $msg = "Label '$label' appears in the reactants but not the products of rule: $rule_text. " + ."The molecule corresponding to labeled object will be deleted when the rule fires. " + ."Please double-check rule if this is not your intention."; + BNGUtils::line_warning($msg, $linenum); + + } + elsif ( $resolution =~ /^(PM|PC)$/ ) + { + my $msg = "Label '$label' appears in the products but not the reactants of rule: $rule_text. " + ."The molecule corresponding to labeled object will be synthesized when the rule fires. " + ."Please double-check rule if this is not your intention."; + BNGUtils::line_warning($msg, $linenum); + } + } + + + # Read rateLaw + my $rl; + my @rate_laws = (); + + + # Look for TotalRate attribute + # (default behavior is PerSite rate) + if ( $string =~ s/(^|\s)TotalRate(\s|$)/$2/ ) + { $TotalRate = 1; } + + # Extract the Ratelaws.. + + # Get forward ratelaw.. + # temporarily add Reference tags as names in the ParamList + if (%rrefs) { setRefs(\%rrefs, '', $plist); } + # Parse and Create the ratelaw + ( $rl, $err ) = RateLaw::newRateLaw( \$string, $model, $TotalRate, \@reac ); + if ($err) { return [], $err; } + # unset temporary names of Reference tags + if (%rrefs) { unsetRefs(\%rrefs, $plist); } + # Save the ratelaw + push @rate_laws, $rl; + + # Reversible rule requires two valid rate laws + if ($reversible) + { + if ($string =~ /^\s*,/) + { + if ($rl->Type eq "Arrhenius") + { return [], "Found second ratelaw, but Arrhenius rate law is sufficient for both directions"; } + + # get reverse rate law + $string =~ s/^\s*,\s*//; + if (%prefs) { setRefs( \%prefs, '', $plist ); } + ($rl, $err) = RateLaw::newRateLaw( \$string, $model, $TotalRate, \@prod ); + if ($err) { return [], $err; } + if (%prefs) { unsetRefs( \%prefs, $plist ); } + push @rate_laws, $rl; + } + else + { # can't find second rate law + if ( $rl->Type eq "Arrhenius" ) + { # the forward ratelaw will suffice for the forward and reverse rule.. + # first make sure there are no undefined local args for the reverse ratelaw + my $last = @{$rl->Constants}-1; + my @local_args = @{$rl->Constants}[2..$last]; + my @missing_args = grep {not exists $prefs{$_}} @local_args; + if (@missing_args) + { return [], "Arrhenius rate law has undefined local arguments for the reverse direction"; } + + push @rate_laws, $rl; + } + else + { return [], "Expecting--but did not find--second ratelaw for reversible rule"; } + } + } + else + { + if ($string =~ /^\s*,/) { return [], "Unidirection reaction may have only one rate law"; } + } + + #print STDERR "rateLaw = ", $rl->toString(), "\n"; + + + # NOTE1: keywords can be in any order following the ratelaws. + # NOTE2: made keyword extraction safer by checking for white space characters + # or end of string around the keyword. Also, if keyword is extracted midstring + # a space is left in place of keyword. --Justin + + # Set optional priority of rule + my $priority = 0; + if ( $string =~ s/(^|\s)priority\s*=\s*(\S+)(\s|$)/$3/ ) { $priority = $2; } + + # Set DeleteMolecules attribute + if ( $string =~ s/(^|\s)DeleteMolecules(\s|$)/$2/ ) { $DeleteMolecules = 1; } + + # Set MoveConnected attribute + # This flag controls the behavior of a molecule transport rule. + # If true, then a molecule transport will carry all molecules in the species + # connected to the first molecule through a path in the same compartment which + # are NOT named in the pattern. + if ( $string =~ s/(^|\s)MoveConnected(\s|$)/$2/ ) { $MoveConnected = 1; } + + + # Process exclude_reactants/products + my @Rexclude = (); + foreach my $reac (@reac) + { push @Rexclude, []; } + + my @Pexclude = (); + foreach my $prod (@prod) + { push @Pexclude, []; } + + while ( $string =~ s/exclude_(\w+)(\S+)// ) + { + my $type = $1; + my $arg = $2; + if ( !( $arg =~ s/^\(// ) ) { + return ( [], + "Arguments to exclude_$type must be enclosed in parenthesis" + ); + } + if ( !( $arg =~ s/\)$// ) ) { + return ( [], "exclude_$type missing close parenthesis" ); + } + + # First argument is number of reactant or product + if ( !( $arg =~ s/^\s*(\d+)\s*[,]// ) ) { + return ( [], + "exclude_$type first argument must be index of $type" ); + } + my $index = $1 - 1; + + if ( $type eq "reactants" ) { + my $max_index = $#reac; + if ( $index < 0 || $index > $max_index ) { + return ( [], "exclude_$type index $index out of range" ); + } + my $sep = '^,'; + while ($arg) { + $g = SpeciesGraph->new(); + $err = $g->readString( \$arg, $clist, 0, $sep, $mtlist ); + $arg =~ s/$sep//; + if ($err) { return ( [], $err ) } + push @{ $Rexclude[$index] }, $g; + } + } + elsif ( $type eq "products" ) { + my $max_index = $#prod; + if ( $index < 0 || $index > $max_index ) { + return ( [], "exclude_$type index $index out of range" ); + } + my $sep = '^,'; + while ($arg) { + $g = SpeciesGraph->new(); + $err = $g->readString( \$arg, $clist, 0, $sep, $mtlist ); + $arg =~ s/$sep//; + if ($err) { return ( [], $err ) } + push @{ $Pexclude[$index] }, $g; + } + } + else { + return ( [], "Unrecognized function exclude_$type" ); + } + } + + + # Process include_reactants/products + my @Rinclude = (); + foreach my $reac (@reac) + { push @Rinclude, []; } + + my @Pinclude = (); + foreach my $prod (@prod) + { push @Pinclude, []; } + + while ( $string =~ s/include_(\w+)(\S+)// ) + { + my $type = $1; + my $arg = $2; + if ( !( $arg =~ s/^\(// ) ) { + return [], "Arguments to include_$type must be enclosed in parenthesis"; + } + if ( !( $arg =~ s/\)$// ) ) { + return [], "include_$type missing close parenthesis"; + } + + # First argument is number of reactant or product + if ( !( $arg =~ s/^\s*(\d+)\s*[,]// ) ) { + return [], "include_$type first argument must be index of $type"; + } + my $index = $1 - 1; + + if ( $type eq "reactants" ) { + my $max_index = $#reac; + if ( $index < 0 || $index > $max_index ) { + return [], "include_$type index $index out of range"; + } + my $sep = '^,'; + while ($arg) { + $g = SpeciesGraph->new(); + $err = $g->readString( \$arg, $clist, 0, $sep, $mtlist ); + $arg =~ s/$sep//; + if ($err) { return ( [], $err ) } + push @{$Rinclude[$index]}, $g; + } + } + elsif ( $type eq "products" ) { + my $max_index = $#prod; + if ( $index < 0 || $index > $max_index ) { + return ( [], "include_$type index $index out of range" ); + } + my $sep = '^,'; + while ($arg) { + $g = SpeciesGraph->new(); + $err = $g->readString( \$arg, $clist, 0, $sep, $mtlist ); + $arg =~ s/$sep//; + if ($err) { return ( [], $err ) } + push @{ $Pinclude[$index] }, $g; + } + } + else { + return [], "Unrecognized function include_$type"; + } + } + + # String should be empty now, otherwise there may be a problem. + if ( $string =~ /\S+/ ) { + my $err = sprintf "Syntax error in reaction rule at $string"; + return [], $err; + } + + + my $rrs = []; + # Construct Forward RxnRule + my $rr = RxnRule->new(); + if ( defined $name ) { $rr->Name($name); } + $rr->Reactants( [@reac] ); + $rr->Products( [@prod] ); + $rr->Priority($priority); + $rr->RateLaw( $rate_laws[0] ); + $rr->Rexclude( [@Rexclude] ); + $rr->Pexclude( [@Pexclude] ); + $rr->Rinclude( [@Rinclude] ); + $rr->Pinclude( [@Pinclude] ); + $rr->Direction(1); + $rr->TotalRate($TotalRate); + $rr->DeleteMolecules($DeleteMolecules); + $rr->MoveConnected($MoveConnected); + $rr->RRefs( {%rrefs} ); + $rr->PRefs( {%prefs} ); + + # Find mapping of reactants onto products + if ( $err = $rr->findMap($mtlist) ) { return [], $err; } + push @$rrs, $rr; + + if ($reversible) + { + $rr = RxnRule->new(); + #if ( defined $name ) { $rr->Name("${name}(reverse)"); } + if ( defined $name ) { $rr->Name("_reverse_${name}"); } + $rr->Reactants( [@prod] ); + $rr->Products( [@reac] ); + $rr->Priority($priority); + $rr->RateLaw( $rate_laws[1] ); + $rr->Pexclude( [@Rexclude] ); + $rr->Rexclude( [@Pexclude] ); + $rr->Pinclude( [@Rinclude] ); + $rr->Rinclude( [@Pinclude] ); + $rr->Direction(-1); + $rr->TotalRate($TotalRate); + $rr->DeleteMolecules($DeleteMolecules); + $rr->MoveConnected($MoveConnected); + $rr->RRefs( {%prefs} ); + $rr->PRefs( {%rrefs} ); + + # Find mapping of reactants onto products + if ( $err = $rr->findMap($mtlist) ) { return [], $err; } + push @$rrs, $rr; + } + + return $rrs; +} + + + +### +### +### + + + +sub listActions +{ + my $rr = shift; + my $out = ''; + + # Species Creation + foreach my $molAddRef ( @{ $rr->MolAdd } ) + { + my @compInhRefs = @$molAddRef; + my $molRef = shift(@compInhRefs); + my ( $p, $m ) = split (/\./, $molRef); + my $newMol = $rr->Products->[$p]->Molecules->[$m]; + $out .= " # Add Species " . $newMol->toString() . "\n"; + } + + # State changes + foreach my $sc ( @{ $rr->CompStateChange } ) + { + ( my $p, my $sR, my $sP ) = @{$sc}; + if ( !defined($sR) ) + { # print wildcard explicitly + $sR = '?'; + } + $out .= " # StateChange($p,$sR->$sP)\n"; + } + + # Compartment changes format: + # + # species: ["ipatt", origin_compartment, destination_compartment, cytosis] + # molecule: ["ipatt.imol", origin_compartment, destination_compartment, cytosis] + # component: ["ipatt.imol.icomp", origin_compartment, destination_compartment, cytosis] + # + # cytosis = 1 if endocytosis (flip orientation of baggage molecules) + # cytosis =-1 if exocytosis (no flip) + # cytosis = 0 otherwise + foreach my $compartment_change ( @{ $rr->ChangeCompartment } ) + { + my ( $ref, $compartR, $compartP, $cytosis ) = @{$compartment_change}; + ( $compartR, $compartP ) = ( $compartR->Name, $compartP->Name ); + $out .= " # ChangeCompartment($ref,$compartR,$compartP,$cytosis)\n"; + } + + # Binding + foreach my $ea ( @{ $rr->EdgeAdd } ) + { + ( my $p1, my $p2 ) = @{$ea}; + $out .= " # Bind($p1,$p2)\n"; + } + + # Dissociation + foreach my $ed ( @{ $rr->EdgeDel } ) + { + ( my $p1, my $p2 ) = @{$ed}; + $out .= " # Unbind($p1,$p2)\n"; + } + + # Molecule Deletion + foreach my $molRef ( @{ $rr->MolDel } ) + { + my ( $p, $m ) = split (/\./, $molRef); + if ( defined($m) ) { + $out .= " # Delete Molecule " + . $rr->Reactants->[$p]->Molecules->[$m]->toString() . "\n"; + } + else { + $out .= + " # Delete Pattern " . $rr->Reactants->[$p]->toString() . "\n"; + } + } + + return ($out); +} + + +## +## + + +# write RxnRule to a BNGL string +sub toString +{ + my $rr = shift @_; + my $rr_rev = @_ ? shift @_ : undef; + + my $string = ''; + + # Reaction name + # Name is an index unless it contains non-digit character + if ( defined $rr->Name and $rr->Name ne '' ) + { $string .= $rr->Name . ": "; } + + # Reactant Patterns + if ( @{$rr->Reactants} ) + { + my $i = 0; + foreach my $g ( @{$rr->Reactants} ) + { + if ( $i != 0 ) { $string .= " + "; } + $string .= $g->toString(); + ++$i; + } + } + else + { # null pattern + $string .= SpeciesGraph::getNullString(); + } + + # Directional Arrow + $string .= (defined $rr_rev) ? " <-> " : " -> "; + + # Product Patterns + if ( @{$rr->Products} ) + { + my $i = 0; + foreach my $g ( @{$rr->Products} ) + { + if ( $i != 0 ) { $string .= " + "; } + $string .= $g->toString(); + ++$i; + } + } + else + { # null pattern + $string .= SpeciesGraph::getNullString(); + } + + # Ratelaw + $string .= " " . $rr->RateLaw->toString(); + if ($rr_rev and not ($rr->RateLaw->Type eq "Arrhenius") ) + { $string .= ", " . $rr_rev->RateLaw->toString(); } + + # Priority + if ( $rr->Priority != 0 ) + { $string .= sprintf " priority=%d", $rr->Priority; } + + # Include/Exclude + foreach my $i ( 0 .. $#{$rr->Rexclude} ) + { + next unless ( @{$rr->Rexclude->[$i]} ); + $string .= " exclude_reactants("; + $string .= $i + 1; + foreach my $g ( @{$rr->Rexclude->[$i]} ) + { $string .= ',' . $g->toString(); } + $string .= ")"; + } + + foreach my $i ( 0 .. $#{$rr->Pexclude} ) + { + next unless ( @{$rr->Pexclude->[$i]} ); + $string .= " exclude_products("; + $string .= $i + 1; + foreach my $g ( @{$rr->Pexclude->[$i]} ) + { $string .= ',' . $g->toString(); } + $string .= ")"; + } + + foreach my $i ( 0 .. $#{$rr->Rinclude} ) + { + next unless ( @{$rr->Rinclude->[$i]} ); + $string .= " include_reactants("; + $string .= $i + 1; + foreach my $g ( @{$rr->Rinclude->[$i]} ) + { $string .= ',' . $g->toString(); } + $string .= ")"; + } + + foreach my $i ( 0 .. $#{$rr->Pinclude} ) + { + next unless ( @{$rr->Pinclude->[$i]} ); + $string .= " include_products("; + $string .= $i + 1; + foreach my $g ( @{$rr->Pinclude->[$i]} ) + { $string .= ',' . $g->toString(); } + $string .= ")"; + } + + # Keywords + $string .= " TotalRate" if ( $rr->TotalRate ); + $string .= " DeleteMolecules" if ( $rr->DeleteMolecules ); + $string .= " MoveConnected" if ( $rr->MoveConnected ); + + return $string; +} + + + +### +### +### + + + +sub toStringSSC +{ + my $rr = shift; + my $rr_rev = (@_) ? shift : 0; + my $pstring = ""; + my $rstring = ""; + my $rstring2 = ""; + my $finalString = ""; + my $errmsg = 0; + my %pattern1; #A hash which stores molecue index for pattern1 as value and key as $mol_index + my %pattern2; + my $mol_index = 1; + my $seen_bond = 0; #This keeps track of the highest edge reached in a molecule + my $checkEdge = 0; #equated to 1 to resolve the molecule that are identified with same edge + my $delMolCase = 0; + my @sameReac1; #while permuting the ractants which do not need any permutation + my %combinations1; #stores the permuted reactant as value, with key as component + my @sameReac2; + my %combinations2; + my %prod1; #stores the permutation of the product as value, with compoennt as key + my %prod2; + my $expR1 = 0; #index to increment 1st reactant permutations + my $expR2 = 0; + my $expP1 = 0; #index to increment ist product permutations + my $expP2 = 0; + my $sameProd1; #string storing not permutated products + my $sameProd2; + + # --Molecule Deletion + my $i = 0; + my $curLabel; + for my $molRef ( @{ $rr->MolDel } ) { + my ( $p, $m ) = split (/\./, $molRef); + if ( $i != 0 ) { $pstring .= ";"; } + if ( defined $m ) + { + my $delMol = $rr->Reactants->[$p]->Molecules->[$m]->toStringSSC(); + $pstring .= "destroy "; + $delMolCase = 1; + } + else + { + my $delMol = $rr->Reactants->[$p]->toStringSSC(); + $pstring .= "destroy complex "; + $delMolCase = 2; + + # SSC needs a tagged molecule for the deletion, so we'll pick + # the first one in the pattern. --Justin + $m = 0; + } + + # just identifying patterns, putting them in teh same hash and giving the labels + # also checks if reaction is on same molecule, assign it as a different label + if ( $p == 0 ) { + if ( exists $pattern1{$m} ) { + $curLabel = $pattern1{$m}; + ++$mol_index; + } + else { + $pattern1{$m} = $mol_index; + $curLabel = $mol_index; + ++$mol_index; + } + } + if ( $p == 1 ) { + if ( exists $pattern2{$m} ) { + $curLabel = $pattern2{$m}; + ++$mol_index; # TODO: missing increment here, is this correct now? --Justin, 15dec2010 + } + else { + $pattern2{$m} = $mol_index; + $curLabel = $mol_index; + ++$mol_index; + } + } + + ++$i; + $pstring .= "Mol" . $curLabel; + } + + # --Species Creation + for my $molAddRef ( @{ $rr->MolAdd } ) { + if ( $i != 0 ) { $pstring .= ";"; } + my @compInhRefs = @$molAddRef; + my $molRef = shift(@compInhRefs); + my ( $p, $m ) = split (/\./, $molRef); + my $newMol = $rr->Products->[$p]->Molecules->[$m]; + my $addMol = $newMol->toString(); + $pstring .= " new "; + $pstring .= $addMol; + ++$i; + } + + for my $ea ( @{ $rr->EdgeAdd } ) { + ( my $p1, my $p2 ) = @{$ea}; + my $pstring1 = $rr->MapR->{$p1}; #Mapping back to reactants + my $pstring2 = $rr->MapR->{$p2}; + + ( my $pat1, my $mol1, my $comp1 ) = split (/\./, $pstring1); + ( my $pat2, my $mol2, my $comp2 ) = split (/\./, $pstring2); + + if ( $i != 0 ) { $pstring .= ";"; } + my $newComp1 = $rr->Reactants->[$pat1]->Molecules->[$mol1]->Components->[$comp1]; + my $newComp2 = $rr->Reactants->[$pat2]->Molecules->[$mol2]->Components->[$comp2]; + + my $tempstring; + ( $tempstring, my $checkComp1 ) = $rr->Reactants->[$pat1]->Molecules->[$mol1]->toStringSSC(); + ( $tempstring, my $checkComp2 ) = $rr->Reactants->[$pat2]->Molecules->[$mol2]->toStringSSC(); + + my $label1; + my $label2; + + if ( $pat1 == 0 ) { + if ( exists $pattern1{$mol1} ) { + $label1 = $pattern1{$mol1}; + ++$mol_index; + } + else { + $pattern1{$mol1} = $mol_index; + $label1 = $mol_index; + ++$mol_index; + } + } + if ( $pat2 == 0 ) { + if ( exists $pattern1{$mol2} ) { + $label2 = $pattern1{$mol2}; + ++$mol_index; + } + else { + $pattern1{$mol2} = $mol_index; + $label2 = $mol_index; + ++$mol_index; + } + } + + if ( $pat1 == 1 ) { + if ( exists $pattern2{$mol1} ) { + $label1 = $pattern2{$mol1}; + ++$mol_index; + } + else { + $pattern2{$mol1} = $mol_index; + $label1 = $mol_index; + ++$mol_index; + } + } + if ( $pat2 == 1 ) { + if ( exists $pattern2{$mol2} ) { + $label2 = $pattern2{$mol2}; + ++$mol_index; + } + else { + $pattern2{$mol2} = $mol_index; + $label2 = $mol_index; + ++$mol_index; + } + } + if ( defined $newComp1->State ) { + $pstring .= " " . "Mol" . $label1 . "\." . $newComp1->Name . "Binds"; + } + else { $pstring .= " " . "Mol" . $label1 . "\." . $newComp1->Name; } + $pstring .= "#"; + + if ( defined $newComp2->State ) { + $pstring .= "Mol" . $label2 . "\." . $newComp2->Name . "Binds"; + } + else { + $pstring .= "Mol" . $label2 . "\." . $newComp2->Name; + } + my $compName1 = $newComp1->Name; + my $compName2 = $newComp2->Name; + + if ( $checkComp1 != 0 ) { + #permute products if its the component with same name + # get the information for same component for that molecule + ( my %compHash ) = $rr->Reactants->[$pat1]->Molecules->[$mol1]->getCompHash(); + foreach my $key ( keys(%compHash) ) { + if ( ( $compHash{$key} ) > 0 ) { + if ( $compName1 == $key ) { + #now permute products + my $iter = $compHash{$key}; + for ( $i = 0 ; $i < $iter ; ++$i ) { + my $tempPString; + my $addLabel = $i + 1; + if ( defined $newComp1->State ) { + $tempPString .= " " . "Mol" . $label1 . "\." . $newComp1->Name . $addLabel . "Binds"; + } + else { + $tempPString .= " " . "Mol" . $label1 . "\." . $newComp1->Name . $addLabel; + } + $tempPString .= "#"; + $prod1{$addLabel} = $tempPString; + # print"\n product permutation for $compName1 for $addLabel is $tempPString \n"; + ++$expP1; + } + } + } + } + } + + if ( $checkComp1 == 0 ) { + if ( defined $newComp1->State ) { + $sameProd1 .= " " . "Mol" . $label1 . "\." . $newComp1->Name . "Binds"; + } + else { + $sameProd1 .= " " . "Mol" . $label1 . "\." . $newComp1->Name; + } + $sameProd1 .= "#"; + } + + if ( $checkComp2 == 0 ) { + if ( defined $newComp2->State ) { + $sameProd2 .= " " . "Mol" . $label2 . "\." . $newComp2->Name . "Binds"; + } + else { + $sameProd2 .= " " . "Mol" . $label2 . "\." . $newComp2->Name; + } + } + + if ( $checkComp2 != 0 ) { + #permute products if its the component with same name + ( my %compHash ) = $rr->Reactants->[$pat2]->Molecules->[$mol2]->getCompHash(); + foreach my $key ( keys(%compHash) ) { + if ( ( $compHash{$key} ) > 0 ) { + if ( $compName2 == $key ) { + #now permute products + my $iter = $compHash{$key}; + for ( $i = 0 ; $i < $iter ; ++$i ) { + my $tempPString; + my $addLabel = $i + 1; + + if ( defined $newComp2->State ) { + $tempPString .="Mol" . $label2 . "\.". $newComp2->Name . $addLabel . "Binds"; + } + else { + $tempPString .= "Mol" . $label2 . "\.". $newComp2->Name. $addLabel; + } + $prod2{$addLabel} = $tempPString; + ++$expP2; + } + } + } + } + } + ++$i; + + if ( $expP1 != 0 && $expP2 == 0 ) { + for ( my $i = 0 ; $i < $expP1 ; ++$i ) { + my $temp = $prod1{ ( $i + 1 ) }; + $temp .= $sameProd2; + $prod1{ ( $i + 1 ) } = $temp; + #print "\n final permutated string is $temp \n"; + } + } + if ( $expP1 == 0 && $expP2 != 0 ) { + for ( my $i = 0 ; $i < $expP2 ; ++$i ) { + my $temp = $sameProd1; + $temp .= $prod2{ ( $i + 1 ) }; + $prod2{ ( $i + 1 ) } = $temp; + #print "\n final permutated string is $temp \n"; + } + } + if ( $expP1 != 0 && $expP2 != 0 ) { + #see how to iterate if we have to permute both the products + } + # also to check for dangling edges and same edge label for reactions with same component + } + + # --Dissociation + for my $ed ( @{ $rr->EdgeDel } ) { + ( my $p1, my $p2 ) = @{$ed}; + + ( my $pat1, my $mol1, my $comp1 ) = split (/\./, $p1); + ( my $pat2, my $mol2, my $comp2 ) = split (/\./, $p2); + + my $newComp1 = $rr->Reactants->[$pat1]->Molecules->[$mol1]->Components->[$comp1]; + my $newComp2 = $rr->Reactants->[$pat2]->Molecules->[$mol2]->Components->[$comp2]; + my $unbMol1 .= $pat1 . $mol2; + my $unbMol2 .= $pat2 . $mol2; + ( my $name, my $bond ) = split (/#/, $newComp1->toStringSSC()); + # check for molecules not in delMolecules + if ( $delMolCase == 0 ) { + if ( $i != 0 ) { $pstring .= ";"; } + $pstring .= " break " . $bond; + ++$i; + } + } + + my $stateLabel = -1; + # --State changes + for my $sc ( @{ $rr->CompStateChange } ) { + my $checkComp1; + my $checkComp2; + ( my $p, my $sR, my $sP ) = @{$sc}; + ( my $pat1, my $mol1, my $comp1 ) = split (/\./, $p); + if ( $pat1 == 0 ) { + if ( exists $pattern1{$mol1} ) { + $stateLabel = $pattern1{$mol1}; + ++$mol_index; + } + else { + $pattern1{$mol1} = $mol_index; + $stateLabel = $mol_index; + ++$mol_index; + } + + ( my $tempstring, $checkComp1 ) =$rr->Reactants->[$pat1]->Molecules->[$mol1]->toStringSSC(); + } + + if ( $pat1 == 1 ) { + if ( exists $pattern2{$mol1} ) { + $stateLabel = $pattern2{$mol1}; + ++$mol_index; + } + else { + $pattern2{$mol1} = $mol_index; + $stateLabel = $mol_index; + ++$mol_index; + } + ( my $tempstring, $checkComp2 ) =$rr->Reactants->[$pat1]->Molecules->[$mol1]->toStringSSC(); + } + + my $newComp = $rr->Reactants->[$pat1]->Molecules->[$mol1]->Components->[$comp1]->toStringSSC(); + ( my $my_Comp ) = split (/=/, $newComp); + if ( $i != 0 ) { + $pstring .= ";"; + } # As two state changes are separated, cannot bedefined in one line + + ++$i; + $pstring .= " " . "Mol" . $stateLabel . "." . $my_Comp . "=\"" . $sP . "\""; + + if ( defined($checkComp2) and $checkComp2 != 0 ) { #print "\n comes here \n"; + #permute products if its the component with same name + ( my %compHash ) = $rr->Reactants->[$pat1]->Molecules->[$mol1]->getCompHash(); + foreach my $key ( keys(%compHash) ) { + if ( ( $compHash{$key} ) > 0 ) { + if ( $key == $my_Comp ) { + #now permute products + my $iter = $compHash{$key}; + for ( $i = 0 ; $i < $iter ; ++$i ) { + my $tempPString; + my $addLabel = $i + 1; + $tempPString .= " " . "Mol". $stateLabel . "." . $my_Comp . $addLabel . "=\"" . $sP . "\""; + $prod2{$addLabel} = $tempPString; + #print"\n product permutation!!! for $my_Comp for $addLabel is $tempPString \n"; + ++$expP2; + } + } + } + } + } + if ( defined($checkComp2) and $checkComp1 != 0 ) { #print "\n comes here in 1 \n"; + #permute products if its teh component with same name + ( my %compHash ) = $rr->Reactants->[$pat1]->Molecules->[$mol1]->getCompHash(); + foreach my $key ( keys(%compHash) ) { + if ( ( $compHash{$key} ) > 0 ) { + if ( $my_Comp == $key ) { + #now permute products + my $iter = $compHash{$key}; + for ( $i = 0 ; $i < $iter ; ++$i ) { + my $tempPString; + my $addLabel = $i + 1; + $tempPString .= " " . "Mol" . $stateLabel . ".". $my_Comp . $addLabel . "=\"" . $sP . "\""; + $prod1{$addLabel} = $tempPString; + #print"\n product permutation !!!for $my_Comp for $addLabel is $tempPString \n"; + ++$expP1; + } + } + } + } + } + } + + # Starting reactant side from here + if ( $mol_index <= 2 ) { + my $count = 0; + while ( defined( $rr->Reactants->[0]->Molecules->[$count] ) ) { + foreach my $key ( keys(%pattern1) ) { + if ( $key == $count ) { + my $temp = "Mol" . $pattern1{$key} . ":"; + push( @sameReac1, $temp ); + $rstring .= $temp; + } + } + ( my $temprstring, my $checkComp1 ) = $rr->Reactants->[0]->Molecules->[$count]->toStringSSC(); + $rstring .= $temprstring; + if ( $checkComp1 == 0 ) { push( @sameReac1, $temprstring ) } + if ( $checkComp1 != 0 ) { + #permute products if its teh component with same name + ( my %compHash ) = $rr->Reactants->[0]->Molecules->[$count]->getCompHash(); + foreach my $key ( keys(%compHash) ) { + if ( ( $compHash{$key} ) > 0 ) { + my $searchLabel .= $key . "#"; + my $stateSearchLabel .= $key . "Binds" . "#"; + if ( $temprstring =~ /(?<=$searchLabel)[\d\_]/ ) { + $temprstring =~ s/(?<=$searchLabel)[\d\_]//; + my $putBond; + for my $compObject (@{$rr->Reactants->[0]->Molecules->[$count]->Components}){ + my $tempName = $compObject->Name; + if ( $tempName == $key ) { + for my $edge ( @{ $compObject->Edges } ) { + if ( $edge =~ /^\d+$/ ) { + $putBond = $edge + 1; + } + else { $putBond = "$edge"; } + } + } + } + # here is just to tell that ok at this spot put the permuted molecule + push( @sameReac1, "here" ); + #now permute reactants + my $iter = $compHash{$key}; + for ( $i = 0 ; $i < $iter ; ++$i ) { + my $tempRString; + ++$expR1; + my $addLabel = $i + 1; + $tempRString = $temprstring; + my $newsearchLabel .= $key . $addLabel . "#"; + my $newaddLabel .= $newsearchLabel . $putBond; + $tempRString =~ s/$newsearchLabel/$newaddLabel/; + $combinations1{$addLabel} = $tempRString; + #print "\n reactant permutation for $key for $addLabel is $tempRString \n"; + } + } + if ( $temprstring =~ /(?<=$stateSearchLabel)\d/ ) { + $temprstring =~ s/(?<=$stateSearchLabel)\d//; + my $putBond; + for my $compObject (@{$rr->Reactants->[0]->Molecules->[$count]->Components}){ + my $tempName = $compObject->Name; + if ( $tempName == $key ) { + for my $edge ( @{ $compObject->Edges } ) { + $putBond = $edge + 1; + } + } + } + push( @sameReac1, "here" ); + #now permute reactants + my $iter = $compHash{$key}; + for ( $i = 0 ; $i < $iter ; ++$i ) { + my $tempRString; + ++$expR1; + my $addLabel = $i + 1; + $tempRString = $temprstring; + my $newsearchLabel .= + $key . $addLabel . "Binds" . "#"; + my $newaddLabel .= $newsearchLabel . $putBond; + $tempRString =~ s/$newsearchLabel/$newaddLabel/; + $combinations1{$addLabel} = $tempRString; + + # print "\n reactant permutation for $key for $addLabel is $tempRString \n"; + } + } + else { push( @sameReac1, $temprstring ); } + } + } + } + ++$count; + } + } + + elsif ( $mol_index > 2 ) { + my $count = 0; + while ( defined( $rr->Reactants->[0]->Molecules->[$count] ) ) { + foreach my $key ( keys(%pattern1) ) { + if ( $key == $count ) { + my $temp = "Mol" . $pattern1{$key} . ":"; + push( @sameReac1, $temp ); + $rstring .= $temp; + } + } + ( my $temprstring, my $checkComp1 ) = $rr->Reactants->[0]->Molecules->[$count]->toStringSSC(); + $rstring .= $temprstring; + if ( $checkComp1 == 0 ) { push( @sameReac1, $temprstring ) } + if ( $checkComp1 != 0 ) { + + #permute products if its teh component with same name + ( my %compHash ) = $rr->Reactants->[0]->Molecules->[$count]->getCompHash(); + foreach my $key ( keys(%compHash) ) { + if ( ( $compHash{$key} ) > 0 ) { + my $searchLabel .= $key . "#"; + my $stateSearchLabel .= $key . "Binds" . "#"; + if ( $temprstring =~ /(?<=$searchLabel)[\d\_]/ ) { + $temprstring =~ s/(?<=$searchLabel)[\d\_]//; + my $putBond; + for my $compObject (@{$rr->Reactants->[0]->Molecules->[$count]->Components}){ + my $tempName = $compObject->Name; + if ( $tempName == $key ) { + for my $edge ( @{ $compObject->Edges } ) { + if ( $edge =~ /^\d+$/ ) { + $putBond = $edge + 1; + } + else { $putBond = "$edge"; } + } + } + } + push( @sameReac1, "here" ); + #now permute products + my $iter = $compHash{$key}; + for ( $i = 0 ; $i < $iter ; ++$i ) { + ++$expR1; + my $tempRString; + my $addLabel = $i + 1; + $tempRString = $temprstring; + my $newsearchLabel .= $key . $addLabel . "#"; + my $newaddLabel .= $newsearchLabel . $putBond; + $tempRString =~ s/$newsearchLabel/$newaddLabel/; + $combinations1{$addLabel} = $tempRString; + } + } + if ( $temprstring =~ /(?<=$stateSearchLabel)\d/ ) { + $temprstring =~ s/(?<=$stateSearchLabel)\d//; + my $putBond; + for my $compObject (@{$rr->Reactants->[0]->Molecules->[$count]->Components}){ + my $tempName = $compObject->Name; + if ( $tempName == $key ) { + for my $edge ( @{ $compObject->Edges } ) { + $putBond = $edge + 1; + } + } + } + push( @sameReac1, "here" ); + #now permute products + my $iter = $compHash{$key}; + for ( $i = 0 ; $i < $iter ; ++$i ) { + ++$expR1; + my $tempRString; + my $addLabel = $i + 1; + $tempRString = $temprstring; + my $newsearchLabel .=$key . $addLabel . "Binds" . "#"; + my $newaddLabel .= $newsearchLabel . $putBond; + $tempRString =~ s/$newsearchLabel/$newaddLabel/; + $combinations1{$addLabel} = $tempRString; + } + } + else { push( @sameReac1, $temprstring ); } + } + } + } + ++$count; + #print "\n array is @sameReac1\n"; + } + $count = 0; + foreach my $key ( keys(%pattern2) ) { + if ( defined($key) ) { + $rstring2 .= "Mol"; + } + } + + if ( $rstring2 ne "" ) { + $rstring2 = ""; + $count = 0; + while ( defined( $rr->Reactants->[1]->Molecules->[$count] ) ) { + foreach my $key ( keys(%pattern2) ) { + if ( $key == $count ) { + $rstring2 .= "Mol" . $pattern2{$key} . ":"; + } + } + ( my $temprstring, my $checkComp2 ) = $rr->Reactants->[1]->Molecules->[$count]->toStringSSC(); + $rstring2 .= $temprstring; + if ( $checkComp2 == 0 ) { push( @sameReac2, $temprstring ) } + if ( $checkComp2 != 0 ) { + + #permute products if its teh component with same name + ( my %compHash ) = $rr->Reactants->[1]->Molecules->[$count]->getCompHash(); + foreach my $key ( keys(%compHash) ) { + if ( ( $compHash{$key} ) > 0 ) { + my $searchLabel .= $key . "#"; + my $stateSearchLabel .= $key . "Binds" . "#"; + if ( $temprstring =~ /(?<=$searchLabel)[\d\_]/ ) { + $temprstring =~ s/(?<=$searchLabel)[\d\_]//; + my $putBond; + for my $compObject (@{$rr->Reactants->[1]->Molecules->[$count]->Components}){ + my $tempName = $compObject->Name; + if ( $tempName == $key ) { + for my $edge ( @{ $compObject->Edges } ) + { + if ( $edge =~ /^\d+$/ ) { + $putBond = $edge + 1; + } + else { $putBond = "$edge"; } + } + } + } + push( @sameReac2, "here" ); + #now permute products + my $iter = $compHash{$key}; + for ( $i = 0 ; $i < $iter ; ++$i ) { + ++$expR2; + my $tempRString; + my $addLabel = $i + 1; + $tempRString = $temprstring; + my $newsearchLabel .=$key . $addLabel . "#"; + my $newaddLabel .=$newsearchLabel . $putBond; + $tempRString =~ s/$newsearchLabel/$newaddLabel/; + $combinations2{$addLabel} = $tempRString; + } + } + if ( $temprstring =~ /(?<=$stateSearchLabel)\d/ ) { + $temprstring =~ s/(?<=$stateSearchLabel)\d//; + my $putBond; + for my $compObject (@{$rr->Reactants->[1]->Molecules->[$count]->Components}){ + my $tempName = $compObject->Name; + if ( $tempName == $key ) { + for my $edge ( @{ $compObject->Edges } ) + { + $putBond = $edge + 1; + } + } + } + push( @sameReac2, "here" ); + #now permute products + my $iter = $compHash{$key}; + for ( $i = 0 ; $i < $iter ; ++$i ) { + ++$expR2; + my $tempRString; + my $addLabel = $i + 1; + $tempRString = $temprstring; + my $newsearchLabel .=$key . $addLabel . "Binds" . "#"; + my $newaddLabel .= $newsearchLabel . $putBond; + $tempRString =~ s/$newsearchLabel/$newaddLabel/; + $combinations2{$addLabel} = $tempRString; + } + } + else { push( @sameReac2, $temprstring ); } + } + } + } + ++$count; + } + } + } + $i = 0; + + + for my $g ( @{ $rr->Reactants } ) { + my %seen_edge; # to resolve dangling edges + ++$i; + ( my $num, my $array ) = $g->findConnected(); + if ( $num > 1 ) { + $errmsg = 1; + print STDOUT"\n WARNING: This rule has been omitted as the translator has detected pattern which is disconnectd according to SSC\n"; + print STDOUT"\n Please expnad the necessary rule patterns. See .rxn file for more details.\n"; + } + + # for seeing same edge labels in a reaction + for my $mol ( @{ $g->Molecules } ) { + for my $comp ( @{ $mol->Components } ) { + for my $edge ( @{ $comp->Edges } ) { + if ( $edge =~ /^\d+$/ ) { + my $edge1 = $edge + 1; + $seen_edge{$edge1} = $edge1 + if exists $seen_edge{$edge1}; + + #the above statement see that in case of a dangling edge, each edge is seen twice; + #It stores the pair as a key and value. + #And whichever key doesn't has a value,that edge is dangling and to be replaced by _. + $seen_edge{$edge1} = 0 if not exists $seen_edge{$edge1}; + if ( $i == 1 + && $seen_bond <= $edge + 1 + ) #keeping record of highest edges in the first pattern + { + $seen_bond = $edge + 1; + } + + #this checks if any edge in second pattern is <= seen_bond, it is a case of edge label, + #and increase all the edges by seen_bond + elsif ( $i != 1 && $edge <= $seen_bond ) { + $checkEdge = 1; + } + } + } + } + } + + my @dangling; #iterating over the seen_edge has to record dangling edges + while ( my ( $key, $value ) = each(%seen_edge) ) { + if ( $value == 0 ) { + push( @dangling, $key ); + } + } + if ( $i == 1 ) { + my $size = @dangling; + if ( $size != 0 ) { + for ( my $iter = 0 ; $iter < $size ; $iter++ ) { + my $dang = pop(@dangling); + $rstring =~ s/(?<=\#)$dang/_/; + } + } + } + if ( $i == 2 ) { + my $size = @dangling; + if ( $size != 0 ) { + for ( my $iter = 0 ; $iter < $size ; $iter++ ) { + my $dang = pop(@dangling); + $rstring2 =~ s/(?<=\#)$dang/_/; + } + } + if ( $checkEdge == 1 ) { + $rstring2 =~ s/(?<=\#)\d/$& + $seen_bond/eg; + } + } + } + + $finalString .= "rxn " . $rstring . " " . $rstring2; + $finalString .= " at " . $rr->RateLaw->toString(); + $finalString .= " -> "; + $finalString .= $pstring; + if ( $finalString =~ /\?/ ) { + $errmsg = 1; + print STDOUT"\n WARNING: This rule has been omitted as SSC does not implement ?. Please see .rxn for more detail \n"; + } + + if ( $rr->Priority != 0 ) { + $errmsg = 1; + print STDOUT" \n WARNING: This rule has been omitted as SSC does not implement priority. Please see .rxn file for more details \n"; + } + + for my $i ( 0 .. $#{ $rr->Rexclude } ) { + next unless ( @{ $rr->Rexclude->[$i] } ); + $errmsg = 1; + print STDOUT"\n WARNING: This rule has been omitted as SSC does not implement Rexclude. Please see .rxn file for more details \n"; + } + + for my $i ( 0 .. $#{ $rr->Pexclude } ) { + next unless ( @{ $rr->Pexclude->[$i] } ); + $errmsg = 1; + print STDOUT"\n WARNING: This rule has been omitted as SSC does not implement Pexclude. Please see .rxn file for more details \n"; + } + + for my $i ( 0 .. $#{ $rr->Rinclude } ) { + next unless ( @{ $rr->Rinclude->[$i] } ); + $errmsg = 1; + print STDOUT"\n WARNING: This rule has been omitted as SSC does not implement Rinclude. Please see .rxn file for more details \n"; + } + + for my $i ( 0 .. $#{ $rr->Pinclude } ) { + next unless ( @{ $rr->Pinclude->[$i] } ); + $errmsg = 1; + print STDOUT"\n WARNING: This rule has been omitted as SSC does not implement Pinclude. Please see .rxn file for more details \n"; + } + + if ( $expR1 == 0 && $expP1 == 0 && $expR2 == 0 && $expP2 == 0 ) { + return ( $finalString, $errmsg ); + } + if ( $expP1 != 0 && $expP2 == 0 ) { + for ( my $i = 1 ; $i <= $expP1 ; ++$i ) { + $finalString .= "\n"; + $finalString .= "rxn " . $rstring . " " . $rstring2; + $finalString .= " at " . $rr->RateLaw->toString(); + $finalString .= "->"; + my $tempstring = $prod1{$i}; + $finalString .= $tempstring; + $finalString .= "\n"; + } + return ( $finalString, $errmsg ); + } + + if ( $expP1 == 0 && $expP2 != 0 ) { + for ( my $i = 1 ; $i <= $expP2 ; ++$i ) { + $finalString .= "\n"; + $finalString .= "rxn " . $rstring . " " . $rstring2; + $finalString .= " at " . $rr->RateLaw->toString(); + $finalString .= "->"; + my $tempstring = $prod2{$i}; + $finalString .= $tempstring; + $finalString .= "\n"; + } + return ( $finalString, $errmsg ); + } + + if ( $expR1 != 0 && $expR2 == 0 ) { + my $size = @sameReac1; + for ( my $i = 1 ; $i <= $expR1 ; ++$i ) { + $finalString .= "\n"; + $finalString .= "rxn "; + for ( my $j = 0 ; $j < $size ; ++$j ) { + my $tempstring = $sameReac1[$j]; + if ( $tempstring ne 'here' ) { + $finalString .= $tempstring; + } + if ( $tempstring eq 'here' ) { + my $put = $combinations1{$i}; + $finalString .= $put; + } + } + $finalString .= " " . $rstring2; + $finalString .= " at " . $rr->RateLaw->toString() . "->" . $pstring; + $finalString .= "\n"; + } + return ( $finalString, $errmsg ); + } + + if ( $expR1 == 0 && $expR2 != 0 ) { + my $size = @sameReac2; + for ( my $i = 1 ; $i <= $expR2 ; ++$i ) { + $finalString .= "\n"; + $finalString .= "rxn "; + $finalString .= " " . $rstring; + for ( my $j = 0 ; $j < $size ; ++$j ) { + my $tempstring = $sameReac2[$j]; + if ( $tempstring ne 'here' ) { + $finalString .= $tempstring; + } + if ( $tempstring eq 'here' ) { + my $put = $combinations2{$i}; + $finalString .= $put; + } + } + $finalString .= " at " . $rr->RateLaw->toString() . "->" . $pstring; + $finalString .= "\n"; + } + return ( $finalString, $errmsg ); + } +} + + + +### +### +### + + + +sub toXML +{ + my $rr = shift; + my $indent = shift; + my $index = shift; + my $plist = (@_) ? shift : ""; + + my $string = $indent . "Name ) { + $string .= " name=\"" . $rr->Name . "\""; + } + + # priority + if ( $rr->Priority != 0 ) { + $string .= " priority=\"" . $rr->Priority . "\""; + } + + # multstale + if ( defined $rr->MultScale ) { + $string .= " symmetry_factor=\"" . $rr->MultScale . "\""; + } + + # Objects contained + my $ostring = ""; + my $indent2 = " " . $indent; + my $indent3 = " " . $indent2; + my $indent4 = " " . $indent3; + + # Reactants + { + $ostring .= $indent2 . "\n"; + my $index = 1; + foreach my $patt ( @{ $rr->Reactants } ) + { + my $pid = $id . "_RP" . $index; + $ostring .= $patt->toXML( $indent3, "ReactantPattern", $pid, "" ); + ++$index; + } + $ostring .= $indent2 . "\n"; + } + + # Products + { + $ostring .= $indent2 . "\n"; + my $index = 1; + foreach my $patt ( @{ $rr->Products } ) + { + my $pid = $id . "_PP" . $index; + $ostring .= $patt->toXML( $indent3, "ProductPattern", $pid, "" ); + ++$index; + } + $ostring .= $indent2 . "\n"; + } + + # Add support for Exclude/Include Reactants/Products + # --justin 29may2008 + #Exclude Reactants + foreach my $iReac ( 1 .. @{ $rr->Rexclude } ) + { + if ( @{ $rr->Rexclude->[ $iReac - 1 ] } ) + { + my $pid = $id . '_RP' . $iReac; + $ostring .= $indent2 . "\n"; + my $iPatt = 1; + foreach my $patt ( @{ $rr->Rexclude->[ $iReac - 1 ] } ) { + my $patt_id = $pid . "_Exclude$iPatt"; + $ostring .= $patt->toXML( $indent3, 'Pattern', $patt_id, "" ); + $iPatt++; + } + $ostring .= $indent2 . "\n"; + } + } + + #Include Reactants + foreach my $iReac ( 1 .. @{ $rr->Rinclude } ) + { + if ( @{ $rr->Rinclude->[ $iReac - 1 ] } ) + { + my $pid = $id . '_RP' . $iReac; + $ostring .= $indent2 . "\n"; + my $iPatt = 1; + foreach my $patt ( @{ $rr->Rinclude->[ $iReac - 1 ] } ) { + my $patt_id = $pid . "_Include$iPatt"; + $ostring .= $patt->toXML( $indent3, 'Pattern', $patt_id, "" ); + $iPatt++; + } + $ostring .= $indent2 . "\n"; + } + } + + #Write Exclude Products + foreach my $iProd ( 1 .. @{ $rr->Pexclude } ) + { + if ( @{ $rr->Pexclude->[ $iProd - 1 ] } ) + { + my $pid = $id . '_PP' . $iProd; + $ostring .= $indent2 . "\n"; + my $iPatt = 1; + foreach my $patt ( @{ $rr->Pexclude->[ $iProd - 1 ] } ) { + my $patt_id = $pid . "_Exclude$iPatt"; + $ostring .= $patt->toXML( $indent3, 'Pattern', $patt_id, "" ); + $iPatt++; + } + $ostring .= $indent2 . "\n"; + } + } + + # Write Include Products + foreach my $iProd ( 1 .. @{ $rr->Pinclude } ) + { + if ( @{ $rr->Pinclude->[ $iProd - 1 ] } ) + { + my $pid = $id . '_PP' . $iProd; + $ostring .= $indent2 . "\n"; + my $iPatt = 1; + foreach my $patt ( @{ $rr->Pinclude->[ $iProd - 1 ] } ) { + my $patt_id = $pid . "_Include$iPatt"; + $ostring .= $patt->toXML( $indent3, 'Pattern', $patt_id, "" ); + $iPatt++; + } + $ostring .= $indent2 . "\n"; + } + } + + # RateLaw (need to pass parameter list and reference hash for functional ratelaws!) + $ostring .= $rr->RateLaw->toXML( $indent2, $id, $plist, $rr->RRefs ); + + + # Write Reactant to Product Map + { + $ostring .= $indent2 . "\n"; + my $index = 1; + foreach my $source ( sort keys %{ $rr->MapF } ) + { + $ostring .= $indent3 . "MapF->{$source}; + $ostring .= + " sourceID=\"" . pointer_to_ID( $id . "_R", $source ) . "\""; + $target = pointer_to_ID( $id . "_P", $target ); + if ( $target ne "Null" ) { + $ostring .= " targetID=\"" . $target . "\""; + } + $ostring .= "/>\n"; + ++$index; + } + $ostring .= $indent2 . "\n"; + } + + # Write Operations + $ostring .= $indent2 . "\n"; + + + # first create reverse map + my %map_reverse = (); + { + my $index = 1; + # construct map from product molecules and components onto reactants + foreach my $s ( keys %{ $rr->MapF } ) + { + my $t = $rr->MapF->{$s}; + $map_reverse{$t} = $s; + } + } + + # Re-ordered operations to match the order of application! + # --Justin, 29may2009 + + # Component State Changes + foreach my $sc ( @{ $rr->CompStateChange } ) + { + ( my $p, my $sR, my $sP ) = @{$sc}; + $ostring .= $indent3 . " + # + # molecule transport: + # + # + # component transport: + # + # + # flipOrientation = 1 if species surface transport up or down a path in the compartment tree. + # (flip orientation of baggage molecules, Outside<=>Inside, like endocytosis) + # flipOrientation =-1 if species surface transport to an adjacent branch in the compartment tree. + # (no flip, like exocytosis) + # flipOrientation = 0 if not species surface transport. + # + # moveConnected = 1 if molecule transport and the "compartment connected component" should be co-transported. + # moveConnected = 0 otherwise. + foreach my $compartment_change ( @{ $rr->ChangeCompartment } ) + { + my ( $ref, $compartR, $compartP, $cytosis ) = @{$compartment_change}; + ( $compartR, $compartP ) = ( $compartR->Name, $compartP->Name ); + $ostring .= $indent3 . 'MoveConnected . '"'; + $ostring .= "/>\n"; + } + + + # Edge Deletion + foreach my $ed ( @{ $rr->EdgeDel } ) + { + ( my $rp1, my $rp2, my $pp1, my $pp2) = @{$ed}; + my ($p1, $m1) = split (/\./, $pp1); + my ($p2, $m2) = split (/\./, $pp2); + + $ostring .= $indent3 . "MolAdd } ) + { + $ostring .= $indent3 . "[0] ) . "\""; + $ostring .= "/>\n"; + } + + # Edge Addition + foreach my $ea ( @{ $rr->EdgeAdd } ) + { + ( my $p1, my $p2 ) = @{$ea}; + + if ( exists $map_reverse{$p1} ) + { $p1 = pointer_to_ID( $id . "_R", $map_reverse{$p1} ); } + else + { $p1 = pointer_to_ID( $id . "_P", $p1 ); } + + if ( exists $map_reverse{$p2} ) + { $p2 = pointer_to_ID( $id . "_R", $map_reverse{$p2} ); } + else + { $p2 = pointer_to_ID( $id . "_P", $p2 ); } + + $ostring .= $indent3 . "MolDel } ) + { + my $delMolFlag = $rr->DeleteMolecules; + $ostring .= $indent3 . "\n"; + + # Termination + if ($ostring) + { + $string .= ">\n"; # terminate tag opening + $string .= $ostring; + $string .= $indent . "\n"; + } + else { + $string .= "/>\n"; # short tag termination + } +} + + + +## __ +## | o _ | _ +## |_ | | | /\| |\/| / | |/\ +## | | | | \/| | | \/| |\/ +## | + +# $err = $rr->findMap( $mtlist ); +# Build correspondence map of reactant patterns and product patterns +# and parse out transformations. +sub findMap +{ + my $rr = shift @_; # reaction rule + my $mtlist = shift @_; # molecule-types list + + # clear out transformations + @{$rr->MolDel} = (); + @{$rr->MolAdd} = (); + @{$rr->EdgeDel} = (); + @{$rr->EdgeAdd} = (); + @{$rr->CompStateChange} = (); + @{$rr->ChangeCompartment} = (); + + + # Aggregate reactant and product pattern graphs + my ($rg) = SpeciesGraph::copymerge( @{$rr->Reactants} ); + my ($pg) = SpeciesGraph::copymerge( @{$rr->Products} ); + + + # Set up mapping between molecules of aggregate graphs and molecules of patterns + my @aggMapR = (); + foreach my $ipatt ( 0 .. $#{$rr->Reactants} ) + { + foreach my $imol ( 0 .. $#{$rr->Reactants->[$ipatt]->Molecules} ) + { + push @aggMapR, "$ipatt.$imol"; + } + } + + my @aggMapP = (); + foreach my $ipatt ( 0 .. $#{$rr->Products} ) + { + foreach my $imol ( 0 .. $#{$rr->Products->[$ipatt]->Molecules} ) + { + push @aggMapP, "$ipatt.$imol"; + } + } + + + # Find map between reactant and product graphs + my $map = $rg->findMaps($pg); + unless (defined $map) { return "No valid mapping could be found for this rule."; } + + # Molecules that are destroyed + # map comments (jhogg): this can be based soley on mapF + my @pused = (0) x @{$pg->Molecules}; + my $i_r = 0; + foreach my $p_r ( 0 .. $#{$rr->Reactants} ) + { + my $molecules = $rr->Reactants->[$p_r]->Molecules; + + my @mol_delete; + @mol_delete = (); + foreach my $m_r ( 0 .. $#{$molecules} ) + { + my $i_p = $map->MapF->{$i_r}; + if ( $i_p < 0 ) { + push @mol_delete, $m_r; + } + else { + $pused[$i_p] = 1; + } + ++$i_r; + } + if ( $rr->DeleteMolecules or ($#mol_delete < $#{$molecules}) ) + { + # Delete only molecules by placing pointer to each on deletion list + foreach my $m_r (@mol_delete) + { push @{$rr->MolDel}, "${p_r}.${m_r}"; } + } + else + { + # Delete whole species matching pattern + push @{$rr->MolDel}, $p_r; + } + } + + + # Molecules that are created + foreach my $imP ( 0 .. $#pused ) + { + next unless ( $pused[$imP] == 0 ); + + # Check that this molecule is fully specified, i.e. all components and component states + my $ref = $aggMapP[$imP]; + my ($p, $m) = split (/\./, $ref); + my $mol = $rr->Products->[$p]->Molecules->[$m]; + + # List of pointers to reactant components from which to inherit attributes of each component + my $ic = 0; + my @ilist = (); + foreach my $comp ( @{$mol->Components} ) + { + if ( ( my $cref = $map->MapR->{"$imP.$ic"} ) ne "-1" ) + { + my ( $imR, $icR ) = split (/\./, $cref); + $cref = $aggMapR[$imR] . ".$icR"; + push @ilist, $cref; + } + else + { + # Is component state specified + push @ilist, ''; + } + ++$ic; + } + + if ( my $err = $mtlist->checkMolecule($mol, { IsSpecies => 1, InheritList => \@ilist }) ) + { return "Molecule created in reaction rule: $err"; } + + push @{$rr->MolAdd}, [ ($ref, @ilist) ]; + } + + + # Edges deleted + my @eused = (0) x @{$pg->Edges}; + foreach my $edgeR ( @{$rg->Edges} ) + { + my ($p1R,$p2R) = split (/ /, $edgeR); + next unless ( defined $p1R and defined $p2R ); + + my $p1P = $map->MapF->{$p1R}; + my $p2P = $map->MapF->{$p2R}; + next if ( $p1P < 0 or $p2P < 0 ); + + if ( ref $pg->Adjacency->{$p1P} eq 'HASH' and exists $pg->Adjacency->{$p1P}{$p2P} ) + { # remember that edge label was found on the product side + $eused[ $pg->Adjacency->{$p1P}{$p2P} ] = 1; + next; + } + + # edge not found! create an edge deletion operation! + # get molecule and component index (within reactant aggregate) + my ( $im1, $ic1 ) = split (/\./, $p1R); + my ( $im2, $ic2 ) = split (/\./, $p2R); + #JJT: and product information + my ( $pim1, $pic1 ) = split (/\./, $p1P); + my ( $pim2, $pic2 ) = split (/\./, $p2P); + + # Check if either molecule is deleted. + # if so, the egde is removed as a side-effect and we don't need to + # explicitly remove the edge + next if ( grep {$_ eq $aggMapR[$im1]} @{$rr->MolDel} or grep {$_ eq $aggMapR[$im2]} @{$rr->MolDel} ); + + # check if bond is part of a complex that is deleted + my ($ip1) = split (/\./, $aggMapR[$im1]); + next if ( grep {$_ eq $ip1 } @{$rr->MolDel} ); + + # edge delete operation points to the reactant molecules. + # JJT: added product information so that it can be encoded in bng-xml + push @{$rr->EdgeDel}, [ $aggMapR[$im1] . ".$ic1", $aggMapR[$im2] . ".$ic2", $aggMapP[$pim1] . ".$pic1", $aggMapP[$pim2] . ".$pic2"]; + + } + + + # Edges added : Need to convert pointers to products back to pointers to reactants + # There is a problem for molecules that appear in products but not in reactants. + # For these, the only way to add the edge is to assign the mapping of product molecules + # onto the selected graphs + foreach my $iedgeP ( 0 .. $#{$pg->Edges} ) + { + next unless ( $eused[$iedgeP] == 0 ); + my @ps = split (/ /, $pg->Edges->[$iedgeP]); + next unless ( @ps==2 ); + my $p1P = $ps[0]; + my $p2P = $ps[1]; + my ( $im1, $ic1 ) = split (/\./, $p1P); + my ( $im2, $ic2 ) = split (/\./, $p2P); + $p1P = $aggMapP[$im1] . ".$ic1"; + $p2P = $aggMapP[$im2] . ".$ic2"; + + push @{$rr->EdgeAdd}, [ $p1P, $p2P ]; + } + + + # Check for invalid bond wildcards in products + foreach my $imP ( 0 .. @{$pg->Molecules}-1 ) + { + my $mol = $pg->Molecules->[$imP]; + foreach my $icP ( 0 .. @{$mol->Components}-1 ) + { + my $comp = $mol->Components->[$icP]; + next unless (@{$comp->Edges}); + + my ($imR, $icR) = split (/\./, $map->MapR("$imP.$icP")); + # we already checked synthesized molecules, so we only need to check those with + # a correspondence in the reactants + next if ( $imR == -1 ); + + # assume that if there's a wildcard, it's the only element of Edges + # (This should be enforced elsewhere) + my $edge = $comp->Edges->[0]; + if ($edge eq "+" ) + { + unless ( grep {$_ eq "+"} @{$rg->Molecules->[$imR]->Components->[$icR]->Edges} ) + { + my $err = sprintf("In reaction rule: product component %s has a bond wildcard, ", $comp->toString() ) + ."but the corresponding reactant component does not."; + return $err; + } + } + elsif ($edge eq "?") + { + unless ( grep {$_ eq "?"} @{$rg->Molecules->[$imR]->Components->[$icR]->Edges} ) + { + my $err = sprintf("In reaction rule: product component %s has a bond wildcard, ", $comp->toString() ) + ."but the corresponding reactant component does not."; + return $err; + } + } + } + } + + + # Parse component state changes + foreach my $imR ( 0 .. $#{$rg->Molecules} ) + { + my $imP = $map->MapF->{$imR}; + next unless ( $imP >= 0 ); + + # grab components + my $componentsR = $rg->Molecules->[$imR]->Components; + my $componentsP = $pg->Molecules->[$imP]->Components; + + # loop over components + foreach my $icR ( 0 .. $#{$componentsR} ) + { + # get product component index + my ( $imP, $icP ) = split (/\./, $map->MapF->{"$imR.$icR"}); + + # Get reactant and product state + my $stateR = $componentsR->[$icR]->State; + my $stateP = $componentsP->[$icP]->State; + + # check for defined state transforming to a wildcard (NOT ALLOWED!) + if ( defined($stateR) and !defined($stateP) ) + { + exit_error( "Component with state attribute defined in reactant pattern cannot map" + ." to component with undefined state attribute in product pattern", + $rr->toString() + ); + } + + # if stateR is different than stateP, write state change transformation + # (be careful that we're not comparing undefined things!) + if ( (defined $stateR ? $stateR : '') cmp (defined $stateP ? $stateP : '') ) + { + my $pR = "$aggMapR[$imR].$icR"; + #printf "Component %s changed state from %s to %s\n", $pR, $stateR, $stateP; + push @{$rr->CompStateChange}, [ ($pR, $stateR, $stateP) ]; + } + + # AS-2022 + # Get reactant and product edge as stated above, we assume that the wildcard is the only + # possible edge for a component. This should be enforced somewhere else. + my $edgeR = $componentsR->[$icR]->Edges->[0]; + my $edgeP = $componentsP->[$icP]->Edges->[0]; + + if ( defined $edgeR && $edgeR eq "+" ) { + if ( ! defined $edgeP || $edgeR ne $edgeP ) { + # one component is wildcard and the corresponding + # one isn't, breaking of wildcard bonds is not allowed + print "\n"; + exit_error( "Found illegal wildcard bond breaking in a rule.\n" + ."A wildcard bond in reactants doesn't have a corresponding wildcard bond in products", + $rr->toString() + ); + } + } + # AS-2022 + } + } + + # Compartment changes: + # + # There are two types of compartment changes. + # (1) Species transport: The entire speces is transported. + # syntax: @C1:SpeciesX -> @C2:SpeciesX + # + # Restrictions: + # (a) Species transport is only allowed if the rule + # does not add or remove molecules from the species pattern. + # (b) Transport is volume to volume OR surface to surface only. + # (c) surface to surface transport is restricted to surface pairs + # connected by a volume. + # + # Note: molecules bound to a surface species will be transported to + # a new compartment based on topological inference (endo/exo-cytosis) + # + # At this time we can check for illegal movement between 2-D and 3-D compartments. + # + # To implement species compartment change: + # push @changeCompartment, ["i_pattR", origin_compart, destination_compartment, cytosis] + # + # cytosis = 1 surface-to-surface endocytic species transport (invert Outside/Inside) + # -1 surface-to-surface exocytic species transport (preserve Outside/Inside) + # 0 otherwise (volume-to-volume species transport and all molecule transport). + # + # (2) Molecule transport: Only the molecule is transported. + # syntax: MoleculeX()@C1 -> MoleculeX()@C2 + # + # Restrictions: + # (a) Molecule transport only between adjacent compartments. + # (b) Molecule compartment must be compatible with explicit species compartment + # [final check occurs at time of rule application] + # + # To implement molecule compartment change: + # push @changeCompartment, ["i_pattR.i_molR", origin_compart, destination_compart, cytosis] + # + + # Implementation: (1) Species Transport + # + # We need to be careful here. + # Define mappings: + # mapPattR: {0,1,..,|ReactantPatterns|} -> {-2,-1,0,1,..,|ProductPatterns|} + # + # mapPattR(I) = K >= 0 if for all molecules j in ReactantPattern[I]: mapF(I.j) == K.l for some l, + # and for all molecules l in ProductPattern[K]: mapF(K.l) == I.j for some j. + # mapPattR(I) = -1 if ReactantPattern[i] is deleted by the reaction rule. + # mapPattR(I) = -2 otherwise. + # + # We'll construct this map in three steps. + # (i) build the forward map R->P and store at @mapPattR + # (ii) build the reverse map P->R and store at @mapPattP + # (iii) construct the final map $mapPattR by comparing the forward and reverse maps. + + # First Rewrite forward map entries into form: + # mapf{pR.mR.cR}= "pP.mP.cP"; + my $mapf_new = {}; + foreach my $im1 ( 0 .. $#{$rg->Molecules} ) + { + my $im2 = $map->MapF->{$im1}; + my $pm1 = $aggMapR[$im1]; + my $pm2 = ( $im2 >= 0 ) ? $aggMapP[$im2] : $im2; + $mapf_new->{$pm1} = $pm2; + + #print "map_new: $pm1 -> $pm2\n"; + my $components = $rg->Molecules->[$im1]->Components; + foreach my $ic1 ( 0 .. $#{$components} ) + { + my ( $im2, $ic2 ) = split (/\./, $map->MapF->{"$im1.$ic1"}); + if ( $im2 >= 0 ) + { + $mapf_new->{"$pm1.$ic1"} = "$pm2.$ic2"; + #print "map_new: $pm1.$ic1 -> $pm2.$ic2\n"; + } + else + { + $mapf_new->{"$pm1.$ic1"} = $im2; + #print "map_new: $pm1.$ic1 -> $pm2.$ic2\n"; + } + } + } + + # Rewrite reverse map to entries in form: + # mapr{pP.mP.cP}= "pR.mR.cR"; + my $mapr_new = {}; + foreach my $im1 ( 0 .. $#{$pg->Molecules} ) + { + my $im2 = $map->MapR->{$im1}; + my $pm1 = $aggMapP[$im1]; + my $pm2 = ( $im2 >= 0 ) ? $aggMapR[$im2] : $im2; + $mapr_new->{$pm1} = $pm2; + + #print "map_new: $pm1 -> $pm2\n"; + my $components = $pg->Molecules->[$im1]->Components; + foreach my $ic1 ( 0 .. $#{$components} ) + { + my ( $im2, $ic2 ) = split (/\./, $map->MapR->{"$im1.$ic1"}); + if ( $im2 >= 0 ) + { + $mapr_new->{"$pm1.$ic1"} = "$pm2.$ic2"; + #print "map_new: $pm1.$ic1 -> $pm2.$ic2\n"; + } + else + { + $mapr_new->{"$pm1.$ic1"} = $im2; + #print "map_new: $pm1.$ic1 -> $pm2.$ic2\n"; + } + } + } + + + { + my @mapPattR = (); # map from reactant patterns to product patterns (-1 if deleted, -2 if no consistent map) + my @mapPattP = (); # map from product patterns to reactant patterns (-1 if added, -2 if no consistent map) + + # step (i) + # first find consistent mappings from each Reactant pattern into a Product pattern (or null pattern). + my $i_R = 0; + for ( my $i_pattR = 0; $i_pattR < @{$rr->Reactants}; $i_pattR++ ) + { + foreach my $molR ( @{$rr->Reactants->[$i_pattR]->Molecules} ) + { + my $i_pattP_molP = $mapf_new->{ $aggMapR[ $i_R++ ] }; + my ($i_pattP) = split (/\./, $i_pattP_molP); + + # if pattR mapping has already failed, do nothing + if ( exists $mapPattR[$i_pattR] ) + { + # if inconsistent, set mapPattR = -2 + unless ( $mapPattR[$i_pattR] == $i_pattP ) + { $mapPattR[$i_pattR] = -2; } + } + else + { # assign pattern mapping ( i_pattP, or -1 if deletion ) + $mapPattR[$i_pattR] = $i_pattP; + } + } + } + + # step (ii) + # now find consistent mappings from a Product pattern into a Reactant pattern (or null pattern) + my $i_P = 0; + for ( my $i_pattP = 0; $i_pattP < @{$rr->Products}; $i_pattP++ ) + { + foreach my $molP ( @{$rr->Products->[$i_pattP]->Molecules} ) + { + my $i_pattR_molR = $mapr_new->{ $aggMapP[ $i_P++ ] }; + my ($i_pattR) = split (/\./, $i_pattR_molR); + + # if pattR mapping has already failed, do nothing + if ( exists $mapPattP[$i_pattP] ) + { + # if inconsistent, set mapPattR = -2 + unless ( $mapPattP[$i_pattP] == $i_pattR ) + { $mapPattP[$i_pattP] = -2; } + } + else + { # assign pattern mapping ( i_pattP, or -1 if deletion ) + $mapPattP[$i_pattP] = $i_pattR; + } + } + } + + # step (iii) + # Now check that that reverse mapping is inverse of forward mapping (where defined). + # Pattern mapping is okay if: $mapPattP[ $mapPattR[i] ] = i OR $mapPattR[i] == -1. + for ( my $i_pattR = 0; $i_pattR < @{$rr->Reactants}; $i_pattR++ ) + { + next if ( $mapPattR[$i_pattR] < 0 ); + unless ( $i_pattR == $mapPattP[ $mapPattR[$i_pattR] ] ) + { + # NOTE: the assignment was orginally an equality, is this right now?? --justin + $mapPattR[$i_pattR] = -2; + } + } + + # Now check that that forward mapping is inverse of reverse mapping (where defined). + # Pattern mapping is okay if: $mapPattR[ $mapPattP[i] ] = i OR $mapPattP[i] == -1. + for ( my $i_pattP = 0; $i_pattP < @{$rr->Products}; $i_pattP++ ) + { + next if ( $mapPattP[$i_pattP] < 0 ); + unless ( $i_pattP == $mapPattR[ $mapPattP[$i_pattP] ] ) + { + $mapPattP[$i_pattP] = -2; + } + } + + + ## Pattern Mapping completed + ## ..now looking for transport reactions. + + # Now that we have a Pattern map, we can check for Compartment changes + for ( my $i_pattR = 0; $i_pattR < @{$rr->Reactants}; $i_pattR++ ) + { + # case 1: reactant pattern is deleted => no transport. + if ( $mapPattR[$i_pattR] == -1 ) { next; } + + # case 2: reactant pattern does not have valid map to product pattern + # => can't change a species' location if the molecule composition has changed. + elsif ( $mapPattR[$i_pattR] == -2 ) + { + # Removed by Justin -- we're being permissive about species syntax. + # # species compartment declaration is invalid without map to product pattern + # if ( defined $rr->Reactants->[$i_pattR]->Compartment ) + # { + # exit_error( + # "Reaction Rule specifies a species compartment for reactant in which" + # ." molecules are removed or added.", $rr->toString() + # ); + # } + next; + } + + # case 3: reactant pattern has valid map to product pattern + # get index of corresponding product pattern + my $i_pattP = $mapPattR[$i_pattR]; + + # species compartment defined on both sides of reaction + my $compR = $rr->Reactants->[$i_pattR]->Compartment; + my $compP = $rr->Products->[$i_pattP]->Compartment; + + # if product compartment is not defined, there is no species transport. + # (reactant compartment, if defined, will provide matching context.) + next if ( !defined($compP) ); + + # if product compartment defined, but not reactant, then no Transport. + # Assume that species compoartment is just a post-check on the final product. + # NOTE: this could potentially define a generic transport. + next if ( !defined($compR) and defined($compP) ); + + # Removed by Justin -- we're being permissive about species syntax. + # # error if compartment is defined for one, but not both. + # if ( defined($compR) xor defined($compP) ) + # { + # exit_error( + # "Reaction Rule specifies a species compartment for a pattern on one" + # ." side of the reaction but not for the corresponding species on the" + # ." other side of the reaction.", $rr->toString() + # ); + # } + + # case 3A: compartments are the same. no transport + next if ( $compR == $compP ); + + # transport must move species from surface to surface + # OR volume to volume + unless ( $compR->SpatialDimensions == $compP->SpatialDimensions ) + { + exit_error( "Reaction Rule attempts to transfer a species between compartments" + ." of non-equal SpatialDimensions.", + $rr->toString() + ); + } + + # case 3B: volume to volume + # (no restrictions on adjacency here!) + if ( $compR->SpatialDimensions == 3 ) + { + push @{$rr->ChangeCompartment}, [ $i_pattR, $compR, $compP, 0 ]; + } + + # case 3C: surface to surface + if ( $compR->SpatialDimensions == 2 ) + { + # only allowed between surfaced connected by volume (this is a mimick of endo/exo-cytosis) + my $cytosis = $compR->separated_by_volume($compP); + unless ($cytosis) { + exit_error( "Reaction Rule attempts to transport a membrane species to a membrane" + ." which is not connected to the source compartment by a volume.", + $rr->toString() + ); + } + push @{$rr->ChangeCompartment}, [ $i_pattR, $compR, $compP, $cytosis ]; + } + } + + # Removed by Justin -- we're being permissive about species syntax. + # # One last thing: check for invalid compartment specification on Product side + # for ( my $i_pattP = 0; $i_pattP < @{$rr->Products}; $i_pattP++ ) + # { + # # does product pattern not have a valid map to a reactant pattern? + # if ( $mapPattP[$i_pattP] == -2 ) + # { + # # species compartment declaration is invalid without map to product pattern + # if ( defined $rr->Products->[$i_pattP]->Compartment ) + # { + # exit_error( + # "Reaction Rule specifies a species compartment for product from which" + # ." molecules have been removed or added.", $rr->toString() + # ); + # } + # # otherwise okay. nothing to do. + # next; + # } + # } + + } # done handling species transport + + + # (2) Molecule Transport + # only allowed between adjacent compartments or compartments + # separated by a surface + # begin loop though reactant molecules (track by index) + for ( my $i_molR = 0; $i_molR < @{$rg->Molecules}; $i_molR++ ) + { + # get reactant molecule compartment + my $molR_comp = $rg->Molecules->[$i_molR]->Compartment; + + # get reactant pattern index and compartment (if any) + my ( $i_pattR ) = split (/\./, $aggMapR[$i_molR]); + my $pattR_comp = $rr->Reactants->[$i_pattR]->Compartment; + + # check that molecule and pattern compartments are compatible + if ( defined($pattR_comp) and defined($molR_comp) ) + { + # this isn't perfect. need a "verify_compartments" method + unless ( $pattR_comp->adjacent($molR_comp) ) + { + exit_error( "Reaction Rule molecule and pattern compartments are not compatible.", + $rr->toString() + ); + } + } + + # get mapping from reactant molecule to product molecule + my $i_molP = $map->MapF->{$i_molR}; + + # skip if reactant does not map to a product + next unless ( $i_molP >= 0 ); + + # get product molecule compartment + my $molP_comp = $pg->Molecules->[$i_molP]->Compartment; + + # get product pattern index and compartment (if any) + ( my $i_pattP ) = split (/\./, $aggMapP[$i_molP]); + my $pattP_comp = $rr->Products->[$i_pattP]->Compartment; + + # check that molecule and pattern compartments are compatible. + if ( defined($pattP_comp) and defined($molP_comp) ) + { + # this isn't perfect. need a "verify_compartments" method + unless ( $pattP_comp->adjacent($molP_comp) ) + { + exit_error( "Reaction Rule molecule and pattern compartments are not compatible.", + $rr->toString() + ); + } + } + + # cases + # (1) neither compartment defined. no transport. + next if ( !defined($molR_comp) and !defined($molP_comp) ); + + # (2) error if compartment specified for reactant or product, but not both. + if ( defined($molR_comp) xor defined($molP_comp) ) + { + exit_error( "Reaction Rule specifies compartment for either the reactant or" + ." product molecule, but not both.", + $rr->toString() + ); + } + + # (3A) both product and reactant molecule compartments defined. + # do nothing if compartments are equal. + next if ( $molR_comp == $molP_comp ); + + # (3B) compartment changes. verify integrity of compartment change + # check if compartments are adjacent or separated by a surface + #if ( $molR_comp->adjacent($molP_comp) + # or $molR_comp->separated_by_surface($molP_comp) ) + #{ + push @{$rr->ChangeCompartment}, + [ "$aggMapR[$i_molR]", $molR_comp, $molP_comp, 0 ]; + #} + #else + #{ + # exit_error( "Reaction rule moves reactant molecule to a compartment that is not" + # ." adjacent to or separated by a surface from the orginal compartment.", + # $rr->toString() + # ); + #} + } # end loop through reactant molecules + + ## finished compartment changes. + + + # Determine the reaction center of this rule + my $err = $rr->find_reaction_center( $mapr_new ); + if ($err) { exit_error( "Some problem finding reaction center: $err", $rr->toString() ); } + + ## DETERMINE CORRECTION FACTOR FOR SYMMETRY ## + # |AutR| = number of automorphisms of the reactant patterns + # |AutR| = [AutR:RG]*|RG| = [AutR:RG]*|Stab(RxnCntr)|*|CG| + # + # where RG = RuleGroup (see below) + # Stab(RxnCenter) = stabilizer of the reaction center in RG + # CG = CenterGroup (symmetries in reaction center). + + # In the rule application phase, we lump reactants matches that are equivalent + # up to reaction center. Therefore it's important to only correct for + # symmetries in the reaction center. (but context consideration is important!) + + # Find reactant graph automorphisms + my @r_auto = $rg->isomorphicToSubgraph($rg); + # Find product graph automorphisms + my @p_auto = $pg->isomorphicToSubgraph($pg); + + # Set up product automorphism hash (includes identity - trivial autmorphism) + my %p_auto_hash = (); + foreach my $auto (@p_auto) + { $p_auto_hash{ $auto->toString() } = 1; } + + # For each R automorphism we're checking the existence + # of a P automorphism. Specifically, find autoP s.t for all r + # in the domain of map: + # map o autoR == autoP o map + # + # If we can do this, then we have a symmetry and autoR is an element + # of the Rule Group, RG. If not, the automorphism corresponds to a new + # class of reaction mechanism. + # + # See "getInducedPermutation" for more notes. + my @RuleGroup = (); + my @candP = (); + foreach my $auto ( @r_auto ) + { + my ($permP, $err) = $auto->get_induced_permutation( $map ); + push @candP,$permP; + if ( exists $p_auto_hash{ $permP->toString() } ) + { push @RuleGroup, $auto; } + } + + + # next find the Stabilizer of the Reaction Center + # i.e. the automorphisms in RG that preserve the reaction center + # Stab(RxnCntr) = { f in RG | f(x) = x for all x in RxnCenter } + my @StabRxnCntr = (); + + RG_LOOP: + # check each automorphism + foreach my $auto (@RuleGroup) + { + # need to figure out pattern mapping that is implicit in the molecule mapping + my %patt_map = (); + while ( my ($src_ptr, $targ_ptr) = each %{$auto->MapF} ) + { + next unless ( $src_ptr =~ /^\d+$/ ); + + my ($src_patt) = ( $aggMapR[$src_ptr] =~ /^(\d+)/ ); + my ($targ_patt) = ( $aggMapR[$targ_ptr] =~ /^(\d+)/ ); + + $patt_map{$src_patt} = $targ_patt; + } + + + # loop over reaction patterns (one array for each reactant pattern) + foreach my $Rpatt (@{$rr->ReactionCenter}) + { + # check each center element on this pattern + foreach my $center_element (@$Rpatt) + { + if ($center_element =~ /\./) + { # handle molecule and component elements + + # get pointer, excluding component + (my $ipatt_imol) = ( $center_element =~ /^(\d+\.\d+)/ ); + + # need to convert p.m.c format into m.c format. Ideally, a map + # should be set up simulateous with the construction of aggMapR + + # find p.m in @aggMapR + my $imolAgg; + for (my $i=0; $i < @aggMapR; $i++) + { + if ($aggMapR[$i] eq $ipatt_imol) + { + $imolAgg = $i; + last; + } + } + + # subsitute p.m with m + my $imolAgg_icomp = $center_element; + $imolAgg_icomp =~ s/^(\d+\.\d+)/$imolAgg/; + + # toss automorphism if center element is not conserved + next RG_LOOP unless ( $auto->MapF->{$imolAgg_icomp} eq $imolAgg_icomp ); + } + else + { + # handle pattern elements + next RG_LOOP unless ( $patt_map{$center_element} eq $center_element ); + } + } + } + push @StabRxnCntr, $auto; + } + + + # determine is any reactant graphs are pure context + my @context_rgs = (); + for (my $iR = 0; $iR < @{$rr->Reactants}; ++$iR ) + { + if ( @{$rr->ReactionCenter->[$iR]}==0 ) + { # this reactant pattern has no reaction center! + push @context_rgs, $rr->Reactants->[$iR]; + } + } + + + # count the instances of each unqiue context graph (up-to-isomorphism) + # and calculuate the permutations of the context graph set + my $crg_permutations = 1; + my %crg_instances; + while ( my $crg = shift @context_rgs ) + { + my $instances = 1; + my $iR = 0; + while ( $iR < @context_rgs ) + { + # TODO: make sure isomorphicTo works correctly on patterns! + if ( $crg->isomorphicTo($context_rgs[$iR]) ) + { # toss out this graph and increment instances + splice @context_rgs, $iR, 1; + ++$instances; + } + else + { ++$iR; } + } + $crg_instances{$crg->toString()} = $instances; + $crg_permutations *= RxnRule::factorial($instances); + } + + my $multScale = 1 / (@RuleGroup/@StabRxnCntr) / $crg_permutations; + my $multinv = (@RuleGroup/@StabRxnCntr)*$crg_permutations; + $rr->MultScale($multScale); + + # STATISTICAL FACTOR - DEBUGGING + # OUTPUTS A FILE FOR EACH RULE + # SHOWING AUTOMORPHISM CALCULATIONS + # NAME YOUR RULES FIRST! + # - JOHN SEKAR + + my $aut = defined $BNGModel::GLOBAL_MODEL->Params->{'write_autos'} ? $BNGModel::GLOBAL_MODEL->Params->{'write_autos'} : 0; + my $autfile; + if($aut==1) + { + my $modelname = $BNGModel::GLOBAL_MODEL->Name; + my $rulename = $rr->Name; + my $filename = join("_",($modelname,$rulename,"StatFactorCalculation")).".txt"; + open($autfile,">".$filename) or die; + print $autfile $rr->toString()."\n"; + print $autfile "Reactants: ".$rg->toString()."\n"; + print $autfile "Products: ".$pg->toString()."\n"; + print $autfile "Correspondence Map (map:R->P)\n"; + print $autfile $map->toString()."\n"; + print $autfile "Reactant Automorphisms (autoR:R->R)\n"; + map { print $autfile $_->toString()."\n"; } @r_auto; + print $autfile "Product Automorphisms (autoP:P->P)\n"; + map { print $autfile $_->toString()."\n"; } @p_auto; + print $autfile "Candidate Product Automorphisms (candP = map o autoR o map^-1, candP:P->P)\n"; + map { print $autfile $_->toString()."\n"; } @candP; + print $autfile "Rule Group (common to candP and autoP)\n"; + map { print $autfile $_->toString()."\n"; } @RuleGroup; + print $autfile "|RG|: ".scalar(@RuleGroup)."\n"; + print $autfile "\nStabilizer of the Reaction Center: \nRG autos that are identity functions on the reaction center\n"; + map {print $autfile $_->toString()."\n"} @StabRxnCntr; + print $autfile "|Stab|: ".scalar(@StabRxnCntr)."\n"; + print $autfile "\nPure Context Graphs\n"; + my @k = keys %crg_instances; + if (not @k) {print $autfile "None\n|Crg|: 0! = 1\n"} + else + { + map {print $autfile $_." ".$crg_instances{$_}."\n"} @k; + my $calc = join('',map {$crg_instances{$_}."!"} @k); + print $autfile "|Crg|: ".$calc." = ".$crg_permutations."\n"; + } + print $autfile "\n1/RuleStatFactor = (|RG|/|Stab|)*|Crg| = ".$multinv."\n"; + print $autfile "RuleStatFactor = ".$multScale."\n"; + close($autfile); + } + + + + + + + + + + ## debug symmetry output +# print $rr->toString(), "\n"; +# print STDERR "|autR| = ", scalar(@r_auto), "\n"; +# print STDERR "|autP| = ", scalar(@p_auto), "\n"; +# print STDERR "|RG| = ", scalar(@RuleGroup), "\n"; +# print STDERR "|StabRC| = ", scalar(@StabRxnCntr), "\n"; +# print STDERR "CRG perms = ", $crg_permutations, "\n"; +# print STDERR "multScale = ", $multScale, "\n"; + + + # save maps + $rr->MapF( $mapf_new ); + $rr->MapR( $mapr_new ); + +# print "=====\n", $rr->toString(), "\n"; +# foreach my $key ( keys %{$rr->MapF} ) +# { +# print $key, " -> ", $rr->MapF->{$key}, "\n"; +# } +# print "-----\n"; +# foreach my $key ( keys %{$rr->MapR} ) +# { +# print $key, " -> ", $rr->MapR->{$key}, "\n"; +# } + + # send warning if no transformations were detected + unless ( @{$rr->MolDel} or @{$rr->MolAdd} or @{$rr->EdgeDel} or @{$rr->EdgeAdd} + or @{$rr->CompStateChange} or @{$rr->ChangeCompartment} ) + { + send_warning(sprintf("No transformations detected in reaction rule (%s). Please verify that this was your intent.", + $rr->toString)); + } + + + return ''; +} + + + +# void = $rr->initializeRule() +# Prepare rule for network generation. +sub initializeRule +{ + my $rr = shift @_; + + # clear out the RxnLabels hash + %{$rr->RxnLabels} = (); + + # clear out Rmatches + my $ipatt = 0; + foreach my $rpatt ( @{$rr->Reactants} ) + { + # make sure rmatches is empty! + $rr->Rmatches->[$ipatt] = []; + ++$ipatt; + } + + # create CartesianProduct object to manage rule instances + my $cartprod_reactants = CartesianProduct::new(); + $cartprod_reactants->initialize( $rr->Rmatches ); + $rr->RuleInstances( $cartprod_reactants ); + + return; +} + + + +##----------------## +## Rule Expansion ## +##----------------## +{ + + my $params = { + check_iso => 1, + max_agg => 1e9, + verbose => 0, + max_stoich => {}, + indent => ' ' x 4 + }; + + sub expand_rule + { + # get input arguments + my $rr = shift @_; # this reaction rule + my $species_list = shift @_; # apply rules with these new species + my $model = shift @_; # model + my $user_params = (@_) ? shift : {}; + + # overwrite defaults with user params + while ( my ($opt,$val) = each %$user_params ) + { $params->{$opt} = $val; } + + # define return values + my $err = undef; + my $n_new_rxns = 0; + + # only look for matches in species that we haven't applied the rules to yet. + my $new_species = []; + foreach my $s (@$species_list) + { + unless ( $s->RulesApplied ) + { push @$new_species, $s->SpeciesGraph; } + } + + # loop over new rule instances (this is required here for 0th order reactions + my $rule_instance = []; + while ( $rr->RuleInstances->getNext($rule_instance) ) + { + # apply rule to reactant set and get the resulting reaction + my $rxn = $rr->build_reaction( $rule_instance, $model, $params ); + if (defined $rxn) + { $n_new_rxns += $model->RxnList->add( $rxn, 0, $model->ParamList ); } + } + + # loop through reactants in reverse order so that the order of reactions is the + # same as the old applyRule method + for (my $ipatt = @{$rr->Reactants}-1; $ipatt >= 0; --$ipatt ) + { + # find embeddings of reacant pattern $rpatt in @$new_species. + my $new_matches = $rr->find_embeddings( $ipatt, $new_species, $model ); + + # tell RuleInstances about new matches + $rr->RuleInstances->update( $ipatt, $new_matches ); + + if ( $params->{verbose} ) + { + my $n_new_matches = @{$rr->Rmatches->[$ipatt]}; + printf $params->{indent} . " ..found %d new match%s to reactant pattern %d\n", + $n_new_matches, ($n_new_matches==1 ? '' : 'es'), $ipatt+1; + } + + # loop over new rule instances + my $rule_instance = []; + while ( $rr->RuleInstances->getNext($rule_instance) ) + { + # apply rule to reactant set and get the resulting reaction + my $rxn = $rr->build_reaction( $rule_instance, $model, $params ); + + if (defined $rxn) + { $n_new_rxns += $model->RxnList->add( $rxn, 0, $model->ParamList ); } + } + } + + return ($err, $n_new_rxns); + } + +} + + + +### +### +### + + + +# Find embeddings of reactant pattern $ipatt in the list $sg_list. +sub find_embeddings +{ + my $rr = shift @_; + my $ipatt = shift @_; + my $sg_list = shift @_; + my $model = shift @_; + + my $all_new_matches = []; + SGLOOP: + foreach my $sg ( @$sg_list ) + { + # check for inclusion of potential target + if (@{$rr->Rinclude->[$ipatt]}) + { + my $include = 0; + foreach my $patt_incl ( @{$rr->Rinclude->[$ipatt]} ) + { + if ( $patt_incl->isomorphicToSubgraph($sg) ) + { + $include = 1; + last; + } + } + next unless ($include); + } + + # check for exclusion of potential target + foreach my $patt_excl ( @{$rr->Rexclude->[$ipatt]} ) + { next SGLOOP if ( $patt_excl->isomorphicToSubgraph($sg) ); } + + # find subgraph isomorphisms + my @new_matches = $rr->Reactants->[$ipatt]->isomorphicToSubgraph($sg); + + # compare matches to see if the reaction center is identical: + # Llet f[i] be the map from reactant pattern into + # a species induced by match[i]. Let f[i]|rxn_center be the + # restriction of f[i] to the subset of nodes in the rxn_center + # of the reactant pattern. + # + # If f[i]|rxn_center == f[j]|rxn_center + # + # then the match[j] is the same up to the reaction center as match[i] + # and we can, wlog, filter match[j]. + + my $err = $rr->filter_identical_by_rxn_center( \@new_matches, $ipatt ); + if ($err) { exit_error( "Some error comparing matches by reaction center: $err.", $rr->toString ); } + + push @$all_new_matches, @new_matches; + } + + return $all_new_matches; +} + + + +### +### +### + + + +# given a reaction rule and a set of reactant pattern matches, this +# method constructs a reaction and returns the number of new reactions and new species +sub build_reaction +{ + my ($rr, $matches, $model, $params) = @_; + + my $verbose = $params->{verbose}; + + # check that reactant targets form an interacting Set (compartment check) + my $targets = [ map {$_->Target} @$matches ]; + if ( @$targets > 1 ) + { return undef unless ( SpeciesGraph::interactingSet(@$targets) ); } + + # get reactant species + my $reactant_species = [ map {$_->Target->Species} @$matches ]; + + # Determine if we are using compartments. + my $using_compartments = $model->CompartmentList->Used(); + + # gather compartments to pass to Rxn + my $compartments = []; + if ($using_compartments) + { $compartments = [ map {$_->Compartment} @$targets ]; } + + + ## Apply transformations + my $products = undef; + ($products) = $rr->apply_operations( $matches ); + # if undefined products are returned, it probably means we violated the "+" or "." operator + return undef unless (defined $products); + + + # Check for correct number of product graphs + my $nprod_patterns = scalar @{$rr->Products}; + if ( @$products != $nprod_patterns ) + { + # If Molecules are being deleted, it is allowed to have more subgraphs than product patterns + if ( $rr->DeleteMolecules and @$products > $nprod_patterns ) + { + if ($verbose) + { printf "Deleting molecules in rule %s\n", $rr->Name(); } + } + # Otherwise, the reaction shouldn't happen + else + { + if ($verbose) + { printf "Rule %s: n_sub (%d)!= n_prod (%d)\n", $rr->Name, @$products, $nprod_patterns; } + return undef; + } + } + + + # Check and Process Product Graphs + my $n_new_species = 0; + my $product_species = []; + for ( my $ip = 0; $ip < @$products; ++$ip ) + { + my $p = $products->[$ip]; + my $iprod = ($ip >= @{$rr->Products}) ? -1 : $ip; + + # check that the product is connected + # NOTE: molecules are placed into products according to (1) a mapping from product molecules + # to product product patterns and (2) connectivity. Therefore it's possible the disconnected + # components have been lumped into the same graph. So at this point we want to check for connectivity. + return undef unless ( $p->isConnected() ); + + # check for Max Aggregation violations + return undef if ( @{$p->Molecules} > $params->{max_agg} ); + + # check for Max Stoichiometry violations + foreach my $mol ( keys %{$params->{'max_stoich'}} ) + { + my $max = $params->{'max_stoich'}->{$mol}; + next if ($max eq "unlimited"); + return undef if ($p->stoich($mol) > $max) + } + + if ($using_compartments) + { + # verify compartments here: + # (1a) try to infer the species compartment from the product graph. + # (1b) if we cannot infer from the graph, try to pick a compartment by analyzing the reactants + # (2) put any unassigned molecules in the species compartment (useful for universal synthesis rules) + # (3) check the topology of the final graph for invalid bonds + # (4) check that product species compartment is the same as the product pattern + + + + + # (0) carries over species compartment information present in the original pattern + if (defined $rr->Products->[$ip]){ + if (defined $rr->Products->[$ip]->Compartment){ + $p->Compartment($rr->Products->[$ip]->Compartment); + } + } + + # (1a) try to infer species compartment from product graph + my ($infer_comp, $err) = $p->inferSpeciesCompartment(); + + # (1b) try to infer species compartment from reactants + if ( $using_compartments and !defined($infer_comp) ) + { + # if there are no reactants, we're in trouble + unless (@$compartments) + { + exit_error( "Unable to assign reaction product to a compartment!\n" + . ">>" . $rr->toString() . "\n" ); + } + # find the surface, if any, and assign product to that surface + foreach my $comp (@$compartments) + { + next unless ( defined $comp ); + if ( $comp->SpatialDimensions == 2 ) + { $infer_comp = $comp; last; } + } + # if no surface, choose the volume + unless ( defined $infer_comp ) + { + foreach my $comp (@$compartments) + { + next unless ( defined $comp ); + if ( $comp->SpatialDimensions == 3 ) + { $infer_comp = $comp; last; } + } + } + } + unless ( defined $infer_comp ) + { + exit_error( "Unable to assign reaction product to a compartment!\n" + . "RxnRule>" . $rr->toString() . "\n" ); + } + + # (2) Assign product species to inferred compartment (possibly undefined). Note that + # this will force all unassigned molecules to the inferred compartment. + $err = $p->assignCompartment($infer_comp); + if ($err) + { + exit_error("$err\n" . "RxnRule>" . $rr->toString() . "\n"); + } + + # (3) Check topology of bonds wwith + unless ( $p->verifyTopology(1) ) + { + print "WARNING: Reaction rule generated a product with invalid bonds with respect" + ." to compartment topology. The invalid reaction is being rejected. This isn't" + ." necessarily a problem, but it's a good idea to double-check your rules. \n" + ."RxnRule>", $rr->toString(), "\n" + ."Product> ", $p->toString(), "\n"; + return undef; + } + + # Check that product species is same compartment as the product pattern! + unless ( $iprod == -1 ) + { + if ( defined $rr->Products->[$iprod]->Compartment ) + { return undef unless ( $infer_comp == $rr->Products->[$iprod]->Compartment ); } + } + } + + + # Put product graph in canonical order (quasi-canonical for the time being) + if ( my $err = $p->sortLabel() ) + { # mysterious problem + exit_error("$err\n" . "RxnRule>" . $rr->toString() . "\n"); + } + + # Does product match excluded pattern? + unless ( $iprod == -1 ) + { + foreach my $patt_excl ( @{$rr->Pexclude->[$iprod]} ) + { return undef if ( $patt_excl->isomorphicToSubgraph($p) ); } + + # Does product match included pattern? Must do so if include patterns are specified. + if (@{$rr->Pinclude->[$iprod]}) + { + my $include = 0; + foreach my $patt_incl ( @{$rr->Pinclude->[$iprod]} ) + { + if ( $patt_incl->isomorphicToSubgraph($p) ) + { + $include = 1; + last; + } + } + return undef unless ($include); + } + } + + + # Update species list; add checks whether this sg is isomorphic to + # an existing species and creates new species if not. It returns + # a pointer to new or existing species with isomorphic sg. + # If we want mapping for this reaction need to update to + # account for reordering of molecules and components + my $spec = $model->SpeciesList->lookup($p, $params->{check_iso}); + if ( not defined $spec ) + { + # add species to the list + $spec = $model->SpeciesList->add($p, 0); + ++$n_new_species; + + # update observables + foreach my $obs ( @{$model->Observables} ) + { $obs->update([$spec]); } + + # update energy patterns (for energy BNG only) + foreach my $epatt ( @{$model->EnergyPatterns} ) + { $epatt->update([$spec]); } + + # remember that we applied the observables + $spec->ObservablesApplied(1); + } + + # Add the product Species + unless ($iprod == -1) + { # TODO: the Fixed product feature will be depreacted in a future release + unless ($rr->Products->[$iprod]->Fixed) + { push @$product_species, $spec; } + } + else + { push @$product_species, $spec; } + + } + + + # Add any reactants with Fixed attribute to products list + # to insure concentration does not change + # TODO: the Fixed reactant feature will be depreacted in a future release + my $ri = 0; + foreach my $rpatt ( @{$rr->Reactants} ) + { + if ( $rpatt->Fixed ) + { push @$product_species, $reactant_species->[$ri]; } + ++$ri; + } + + + # map reference tags to local objects + my $local_refs = {}; + while ( my ($ref,$ptr1) = each %{$rr->RRefs} ) + { + my ($patt_idx,$mol_idx,$comp_idx) = split( /\./, $ptr1 ); + # first remap pattern pointer to a species + my $ptr2 = $reactant_species->[$patt_idx]->Index; + if (defined $mol_idx) + { # next remap the molecule + my ($mol2_idx) = split( /\./, $matches->[$patt_idx]->mapF($mol_idx) ); + $ptr2 .= ".$mol2_idx"; + if (defined $comp_idx) + { # finally remap the component + my ($mol2_idx, $comp2_idx) = split( /\./, $matches->[$patt_idx]->mapF("$mol_idx.$comp_idx") ); + $ptr2 .= ".$comp2_idx"; + } + } + $local_refs->{$ref} = $ptr2; + } + + + # Create reaction + my $rxn = Rxn->new( Reactants=>$reactant_species, Products=>$product_species, + RateLaw=>undef, Priority=>$rr->Priority, RxnRule=>$rr, RxnRuleArray=>[$rr], + StatFactor=>$rr->MultScale, + InstanceHash=> {$rr->Name => 0} ); + + # evaluate ratelaw in local context + my $rl = $rr->RateLaw->evaluate_local($rxn, $local_refs, $model); + $rxn->RateLaw( $rl ); + + # return rxn + return $rxn; +} + + + +### +### +### + + + +sub find_reaction_center +# $err = $rr->find_reaction_center( \%mapr ) +# +# Finds the reaction center of each reactant pattern in a reaction rule. +# Results are stored at the array "RxnRule->ReactionCenter", which has +# length #Patterns. Element [i] of the array is a list +# of reaction center elements for pattern[i]. Rxn_center elements are indexed +# using Jim's pointer notation "iPatt.iMol.iComp" +# +# Rxn_center includes: +# (1) all components whose state, compartment or bond is changed by the rule. +# (2) molecules whose compartment is changed by the rule. +# (3) molecules that are deleted by the rule. +# (4) species whose compartment is changed (explicitly). +# (5) species that are deleted by the rule. +# +# This is subject to change! --justin +# +# This could be done more efficiently in coordination with rule operation construction. +{ + my ( $rr, $mapr ) = @_; # get RxnRule and reverse map (product->reactant) + my $err = ''; + + # initialize a hash dictionary for each reactant pattern + foreach my $iR ( 0 .. @{$rr->Reactants}-1 ) + { $rr->ReactionCenter->[$iR] = {}; } + + foreach my $action ( @{$rr->EdgeAdd} ) + { # edge additions are referenced to product space + # components where edge added are reaction center + my ( $targ1_pointer, $targ2_pointer ) = @$action; + + # map product pointers to reactant pointers + $targ1_pointer = $mapr->{$targ1_pointer}; + $targ2_pointer = $mapr->{$targ2_pointer}; + + unless ( $targ1_pointer eq -1 ) { + my ($iPatt1) = ( $targ1_pointer =~ /^(\d+)/ ); + $rr->ReactionCenter->[$iPatt1]->{$targ1_pointer} = 1; + } + + unless ( $targ2_pointer eq -1 ) { + my ($iPatt2) = ( $targ2_pointer =~ /^(\d+)/ ); + $rr->ReactionCenter->[$iPatt2]->{$targ2_pointer} = 1; + } + } + + foreach my $action ( @{ $rr->EdgeDel } ) + { # edge deletions are referenced to reactant space + # components where edge deleted are reaction center + my ( $targ1_pointer, $targ2_pointer ) = @$action; + my ($iPatt1) = ( $targ1_pointer =~ /^(\d+)/ ); + $rr->ReactionCenter->[$iPatt1]->{$targ1_pointer} = 1; + + my ($iPatt2) = ( $targ2_pointer =~ /^(\d+)/ ); + $rr->ReactionCenter->[$iPatt2]->{$targ2_pointer} = 1; + } + + foreach my $targ_pointer ( @{ $rr->MolDel } ) + { # molecule deletions are referenced to reactant space + my ($iPatt) = ( $targ_pointer =~ /^(\d+)/ ); + $rr->ReactionCenter->[$iPatt]->{$targ_pointer} = 1; + # NOTE1: a Species delete rule will add Species as "Rxn Center" + # NOTE2: edges implicitly deleted by molecule delete are not reaction center. + } + + foreach my $action ( @{ $rr->CompStateChange } ) + { # components with state changes are rxn center + # component changes are referenced to reactant space + my ($targ_pointer) = @$action; + my ($iPatt) = ( $targ_pointer =~ /^(\d+)/ ); + $rr->ReactionCenter->[$iPatt]->{$targ_pointer} = 1; + } + + foreach my $action ( @{ $rr->ChangeCompartment } ) + { # molecules with compartment changes are rxn center + # compartment changes are referenced to reactant space + my ($targ_pointer) = @$action; + my ($iPatt) = ( $targ_pointer =~ /^(\d+)/ ); + $rr->ReactionCenter->[$iPatt]->{$targ_pointer} = 1; + # NOTE: a Species transport will add Species as "Rxn Center" + } + + # rewrite each hash dictionary as an array + foreach my $iR ( 0 .. @{$rr->ReactionCenter}-1 ) + { $rr->ReactionCenter->[$iR] = [ keys %{$rr->ReactionCenter->[$iR]} ]; } + + return $err; +} + + +### +### +### + + + +sub filter_identical_by_rxn_center +# $err = $rr->filter_identical_by_rxn_center( \@matches, $iPatt ) +# +# Let @matches be a set of matches from Reactant[$iPatt] to a single target +# species. This routine removes extra matches which are identical up to +# the rxn center. --justin +# +# specifically, let f[i] be the map from reactant pattern into +# a species induced by match[i]. Let f[i]|rxn_center be the +# restriction of f[i] to the subset of nodes in the rxn_center +# of the reactant pattern. +# +# If match[i]->Target == match[j]->Target +# and +# f[i]|rxn_center == f[j]|rxn_center +# +# then the match[j] is the same up to the reaction center as match[i] +# and we can, wlog, filter match[j]. +{ + my ( $rr, $match_set, $iPatt ) = @_; + my $err = ''; + + # save time if there's only one match + return $err unless ( @$match_set > 1 ); + + # array to store images of reaction center under match maps. + my @images = (); + + # (1) build image of reaction center under each match map. + foreach my $match (@$match_set) + { + my $image = []; + push @images, $image; + + # generate image by mapping reaction center nodes into the match Target + foreach my $node_pointer ( @{ $rr->ReactionCenter->[$iPatt] } ) + { + my ( $iP, $iMC ) = ( $node_pointer =~ /(\d+)\.?(.*)/ ); + + if ( $iMC ne '' ) + { # molecule or component node + push @$image, "${iPatt}." . $match->MapF->{$iMC}; + } + else + { # species node + push @$image, "${iPatt}"; + } + } + } + + # (2) Compare images and filter identical. + # All against all comparison: N*(N-1) compares, where N=#matches. + # Some efficiency gained by tossing repeats as found. + for ( my $iMatch = 0 ; $iMatch < @images ; $iMatch++ ) + { # each match gets a turn as the template + my $template = $images[$iMatch]; + + JMATCH: + # compare template to all images with higher index + for ( my $jMatch = $iMatch + 1 ; $jMatch < @images ; $jMatch++ ) + { # get image for comparison + my $image = $images[$jMatch]; + + # compare element by element + for ( my $k = 0 ; $k < @{$template} ; $k++ ) { + next JMATCH unless ( $template->[$k] eq $image->[$k] ); + } + + # images are the same. toss jMatch from @$match_set and @images; + splice( @$match_set, $jMatch, 1 ); + splice( @images, $jMatch, 1 ); + + # decrement jMatch to keep things in sync + $jMatch--; + } + } + + return $err; +} + + + +### +### +### + + + +sub apply_operations +# ($products, $label) = $rr->apply_operations(\@matches,\@permute) +# +# Apply rule operations to the reactant set in @matches and return +# products. Also generates an "almost" canonical labeling for the reaction. +# NOTE: canonical labeling isn't fully general w.r.t. operations on newly created molecules. +# +# @matches is an array with elements that are maps from the nth pattern to the nth reactant +# @permute is an array that defines a permutation of the reactants +{ + my $rr = shift @_; + my $matches = shift @_; + my $permute = @_ ? shift @_ : undef; + + # get number of reactants + my $n_reactants = @$matches; + + # get targets + my $targets = [ (map {$_->Target} @$matches) ]; + + # Aggregate matching SpeciesGraphs + my ($g, $offsets) = SpeciesGraph::copymerge(@$targets); + my $mol = $g->Molecules; + + # Build map from product patterns into aggregate product graph + # mapP: product pattern (p.m.c) -> product species (m.c) + my $mapP = {}; + for ( my $ir = 0; $ir < $n_reactants; ++$ir ) + { + # get match to this reactant + my $match = $matches->[$ir]; + + # Map molecules + for ( my $im = 0; $im < @{$match->Source->Molecules}; ++$im ) + { + # nothing to do if molecule ain't in the map + next unless ( exists $rr->MapF->{"$ir.$im"} ); + + # map molecule in reactant pattern to product pattern + my $pP = $rr->MapF->{"$ir.$im"}; + + # nothing to do if maps to -1 (i.e. "delete") + next if ( $pP == -1 ); + + # map molecule in product pattern to aggregate product graph + $mapP->{$pP} = $match->mapF( "$im", $offsets->[$ir] ); + + # Map components + for ( my $ic = 0; $ic < @{$match->Source->Molecules->[$im]->Components}; ++$ic ) + { + # map component in reactant pattern to product pattern + my $pP = $rr->MapF->{"$ir.$im.$ic"}; + # map molecule in product pattern to aggregate product graph + $mapP->{$pP} = $match->mapF( "$im.$ic", $offsets->[$ir] ); + } + } + } + + + # Canonical Labeling, part 1: + # order reactants by canonical label, + # remap offsets to the canonical order. + my $label = ''; + my $canonical_reactant_order = []; + { + my $stack = []; + + # get canonical labels (paired with reactant indices) + my $iR = 0; + foreach my $targ (@$targets) + { + push @$stack, [ $targ->StringExact, $iR ]; + $iR++; + } + + # sort by label + @$stack = ( sort { $a->[0] cmp $b->[0] } @$stack ); + + # build map from original reactant order to canonical reactant order. + # map is needed for later steps. + $iR = 0; + foreach my $targ (@$stack) { + $canonical_reactant_order->[ $targ->[1] ] = $iR; + $iR++; + + # toss out original index + $targ = $targ->[0]; + } + + # concatenate labels + $label .= join( '//', @$stack ); + } + + + # Apply molecule additions + { + my $stack = []; + + foreach my $molAddRef ( @{$rr->MolAdd} ) + { + my @compInhRefs = @$molAddRef; + my $molRef = shift @compInhRefs; + my ( $ip, $im ) = split (/\./, $molRef); + my $newMol = $rr->Products->[$ip]->Molecules->[$im]->copy($molRef); + + # Clear out edges to avoid label clashing!! We'll add bonds later. + @{$newMol->Edges} = (); + foreach my $comp ( @{$newMol->Components} ) + { + @{$comp->Edges} = (); + } + + # Inherit component atributes + my $ic_newMol = 0; + foreach my $compInhRef (@compInhRefs) + { + next unless $compInhRef; + my ( $ip, $im, $ic ) = split (/\./, $compInhRef); + + # permute reactants + if ( defined $permute ) { $ip = $permute->[$ip]; } + + my ( $im_targ, $ic_targ ) = split ( /\./, + $matches->[$ip]->mapF( "$im.$ic", $offsets->[$ip] ) ); + + # Copy component state + my $stateNew = $mol->[$im_targ]->Components->[$ic_targ]->State; + $newMol->Components->[$ic_newMol]->State($stateNew); + ++$ic_newMol; + } + + # Remove labels and set map elements + $newMol->Label(undef); + my $nmol = @{$g->Molecules}; + $mapP->{$molRef} = $nmol; + $ic_newMol = 0; + foreach my $comp ( @{ $newMol->Components } ) + { + $comp->Label(undef); + $mapP->{"$molRef.$ic_newMol"} = "$nmol.$ic_newMol"; + ++$ic_newMol; + } + + push @{$g->Molecules}, $newMol; + + # printf "prod: %s\n", $g->toString(); + # Should add pointer from product pattern to new molecules in $g + + # save molecule addition for canonical labeling + # TODO: get real canonical label for molecule!! + push @$stack, $newMol->toString; + } + + # add molecule addition operations to the canonical label + if (@$stack) + { + @$stack = ( sort { $a cmp $b } @$stack ); + $label .= '|MA/' . join( '/', @$stack ); + } + } + + + # Apply component state changes + { + my $stack = []; + foreach my $sc ( @{$rr->CompStateChange} ) + { + my ( $ref, $stateR, $stateP ) = @$sc; + my ( $ip, $im, $ic ) = split (/\./, $ref); + + # permute reactants + if ( defined $permute ) { $ip = $permute->[$ip]; } + + my ( $im_targ, $ic_targ ) = + split ( /\./, $matches->[$ip]->mapF( "$im.$ic", $offsets->[$ip] ) ); + + $mol->[$im_targ]->Components->[$ic_targ]->State($stateP); + + # save compoent state change for canonical ordering + my $canonical_targ = $canonical_reactant_order->[$ip] . '.' . $matches->[$ip]->mapF("$im.$ic"); + push @$stack, $canonical_targ . ',' . $stateP; + } + + if (@$stack) { + @$stack = ( sort { $a cmp $b } @$stack ); + $label .= '|SC/' . join( '/', @$stack ); + } + } + + + # Apply compartment changes + { + my $stack = []; + + foreach my $comp_change ( @{$rr->ChangeCompartment} ) + { + # parse state change array + my ( $ref, $compartR, $compartP, $cytosis ) = @$comp_change; + + # parse pattern.molecule indexing + my ( $ip, $im, $ic ) = ( split (/\./, $ref) ); + + # permute reactants + if ( defined $permute ) { $ip = $permute->[$ip]; } + + # note:$matches($i_patt) is the map from pattern (with index $idx_pattern) + # to instances in a species graph + if ( defined($ic) and ($ic ne '') ) + { # component compartment chanfge + # implementation of component compartments is not completed (here and elsewhere) + my ( $im_targ, $ic_targ ) = + split (/\./, $matches->[$ip]->mapF( "$im.$ic", $offsets->[$ip] )); + + $mol->[$im_targ]->Components->[$ic_targ]->Compartment($compartP); + + # save compartment change for canonical ordering + push @$stack, $canonical_reactant_order->[$ip] . '.' + . $matches->[$ip]->mapF("$im.$ic") . ',' + . $compartP->Name; + } + elsif ( defined($im) and ($im ne '') ) + { # molecule compartment change + if ( $rr->MoveConnected ) + { # move connected compartment component of $i_mol + # excluding molecules named in reactant pattern. + + # (1) map pattern molecule index to target index + my ($im_targ) = $matches->[$ip]->mapF( "$im", $offsets->[$ip] ); + + # (2) exclude molecules named in reactant pattern (aside from $i_mol) + my @exclude_molecules = (); + for ( my $jm = 0; $jm < @{ $rr->Reactants->[$ip]->Molecules }; $jm++ ) + { + # skip $i_mol + next if ( $jm == $im ); + # map $j_mol into target + my $jm_targ = $matches->[$ip]->mapF( "$jm", $offsets->[$ip] ); + # nothing to do if this molecule is deleted + next if ( $jm_targ < 0 ); + # otherwise, add $j_molT to exclude molecules + push @exclude_molecules, $jm_targ; + } + + # (3) find connected compartment component of molecule + my @compartment_connected = $matches->[$ip]->Target->find_compartment_connected($im_targ); + + # (4) transport molecules + foreach my $jm_targ (@compartment_connected) + { + # skip if $j_molT is excluded + next if ( grep { $_ == $jm_targ } @exclude_molecules ); + # otherwise transport molecule + $mol->[$jm_targ]->Compartment($compartP); + } + + # save compartment change for canonical ordering + push @$stack, $canonical_reactant_order->[$ip] . '.' + . $matches->[$ip]->mapF($im) . ',' + . $compartP->Name . ',' . 'mc'; + } + else + { # move single molecule + my ($im_targ) = $matches->[$ip]->mapF( "$im", $offsets->[$ip] ); + + $mol->[$im_targ]->Compartment($compartP); + + # save compartment change for canonical ordering + push @$stack, $canonical_reactant_order->[$ip] . '.' + . $matches->[$ip]->mapF($im) . ',' + . $compartP->Name; + } + } + else + { # species compartment change + + # save compartment change for canonical ordering + push @$stack, $canonical_reactant_order->[$ip] . ',' . $compartP->Name; + + if ( $cytosis == 0 ) + { # volume to volume transport + # transport all molecules to $compartP + for ( my $im = $offsets->[$ip]; + $im < $offsets->[$ip] + @{ $matches->[$ip]->Target->Molecules }; + $im++ + ) + { + $g->Molecules->[$im]->Compartment($compartP); + } + } + else + { # surface to surface transport + # if $cytosis= 1 [endocytosis]: map Outside to Inside, Inside to Outside + # if $cytosis=-1 [exocytosis]: map Outside to Outside, Inside to Inside + + my $outsideR = $compartR->Outside; + my $insideR = $compartR->Inside->[0]; # should be only one compartment here + + my $outsideP = $compartP->Outside; + my $insideP = $compartP->Inside->[0]; + + if ( $cytosis == 1 ) + { ($insideP, $outsideP) = ($outsideP, $insideP); } + + for ( my $im = $offsets->[$ip]; + $im < $offsets->[$ip] + @{ $matches->[$ip]->Target->Molecules }; + $im++ + ) + { + if ( $g->Molecules->[$im]->Compartment == $compartR ) + { $g->Molecules->[$im]->Compartment($compartP); } + + elsif ( $g->Molecules->[$im]->Compartment == $outsideR ) + { $g->Molecules->[$im]->Compartment($outsideP); } + + elsif ( $g->Molecules->[$im]->Compartment == $insideR ) + { $g->Molecules->[$im]->Compartment($insideP); } + + else + { + exit_error( "surface to surface species transport attempted to move molecule" + . "that is not on or adjacent to the reaction surface.", + $rr->toString + ); + } + } + } # end species transport + } # end compartment change + } # end compartment loop + + # add compartment change operations to the canonical label + if (@$stack) + { + @$stack = ( sort { $a cmp $b } @$stack ); + $label .= '|CC/' . join( '/', @$stack ); + } + } + + + # Apply edge deletions + { + my $stack = []; + + foreach my $edel ( @{$rr->EdgeDel} ) + { + my @targs = (); + my @targs_canonical = (); + + # loop over components connected to the edge + #jjt: only iterate over reactants + foreach my $ref ( @$edel[0..1] ) + { + my ( $ip, $im, $ic ) = split (/\./, $ref); + # permute reactants + if ( defined $permute ) { $ip = $permute->[$ip]; } + + # Find pointer to molecule and component in $g corresponding to $im.$ic in pattern + push @targs, + $matches->[$ip]->mapF( "$im.$ic", $offsets->[$ip] ); + + # get pointer in canonical form + my $ref_canonical = $canonical_reactant_order->[$ip] . '.' + . $matches->[$ip]->mapF("$im.$ic"); + push @targs_canonical, $ref_canonical; + } + + #print "Deleting edge $comps[0] $comps[1]\n"; + my ($ns, $sg) = $g->findConnected(); + $g->deleteEdge(@targs); + # sort components for canonical ordering + @targs_canonical = ( sort cmp_pointer @targs_canonical ); + push @$stack, join( ',', @targs_canonical ); + } + + # add edge deletion operations to the canonical label + if (@$stack) + { + @$stack = ( sort cmp_edge @$stack ); + $label .= '|ED/' . join( '/', @$stack ); + } + } + + + # Apply edge additions + { + my $stack = []; + + my $nedge = 1; + foreach my $eadd ( @{$rr->EdgeAdd} ) + { + # get pointers to components in the super-graph + my $g_ref1 = $mapP->{ $eadd->[0] }; + my $g_ref2 = $mapP->{ $eadd->[1] }; + + # need to map edge adds from super-graph back to reactant patterns, if possible + # (need to do this since reactants are rearranged.. hence its not sufficient to just + # use the pointers into the supergraph) + my $ref1 = undef; + my $ip1 = 0; + EDGE_ADD_LOOP1: + foreach my $map (@$matches) + { + foreach my $ptr ( keys %{$map->MapF} ) + { + if ( $map->mapF( $ptr, $offsets->[$ip1] ) eq $g_ref1 ) + { + $ref1 = $canonical_reactant_order->[ defined $permute + ? $permute->[$ip1] + : $ip1 ] .'.'. $map->mapF($ptr); + last EDGE_ADD_LOOP1; + } + } + $ip1++; + } + unless ( defined $ref1 ) { $ref1 = $g_ref1; } + + # now for the other end of the edge... + my $ref2 = undef; + my $ip2 = 0; + EDGE_ADD_LOOP2: + foreach my $map (@$matches) + { + foreach my $ptr ( keys %{$map->MapF} ) + { + if ( $map->mapF( $ptr, $offsets->[$ip2] ) eq $g_ref2 ) + { + $ref2 = $canonical_reactant_order->[ defined $permute + ? $permute->[$ip2] + : $ip2 ] .'.'. $map->mapF($ptr); + last EDGE_ADD_LOOP2; + } + } + $ip2++; + } + unless ( defined $ref2 ) { $ref2 = $g_ref2; } + + # APPLY edge addition now + $g->addEdge( "ne${nedge}", $g_ref1, $g_ref2 ); + ++$nedge; + + # TODO: edges added to new molecules may not be in canonical form! + # save edge addition for canonical labeling + push @$stack, join( ',', sort cmp_pointer ( $ref1, $ref2 ) ); + } + + # add edge addition operations to the canonical label + if (@$stack) + { + @$stack = ( sort cmp_edge @$stack ); + $label .= '|EA/' . join( '/', @$stack ); + } + } + + + my $temp = 0; + # Apply molecule/pattern deletions + # NOTE: do this last because molecule indices will change after deletion. + my $del_list = []; # list of molecules to delete (by index) in the aggregate product + { + my $stack = []; + + foreach my $molref ( @{$rr->MolDel} ) + { + #print STDERR "molDel\n"; + my ( $ip, $im ) = split (/\./, $molref); + + # permute reactants + if ( defined $permute ) { $ip = $permute->[$ip]; } + + if ( defined $im ) + { + # Delete molecule + my $im_targ = $matches->[$ip]->mapF( "$im", $offsets->[$ip] ); + + $g->Molecules->[$im_targ] = undef; + push @$del_list, $im_targ; + + # save molecule delete for canonical labeling + push @$stack, $canonical_reactant_order->[$ip] . '.' + . $matches->[$ip]->mapF($im); + + # update edges + } + else + { + # Delete whole pattern + my $im_targ_max = + $offsets->[$ip] + $#{ $matches->[$ip]->Target->Molecules }; + foreach my $im_targ ( $offsets->[$ip] .. $im_targ_max ) + { + $g->Molecules->[$im_targ] = undef; + push @$del_list, $im_targ; + } + + # save pattern delete for canonical labeling + push @$stack, $canonical_reactant_order->[$ip]; + } + } + + # compress product graph (eliminate undefined molecules!) + my $im = 0; + while ( $im < @{$g->Molecules} ) + { + unless ( defined $g->Molecules->[$im] ) + { + $temp = 1; + splice @{$g->Molecules}, $im, 1; + next; + } + $im++; + } + + # add molecule deletion operations to the canonical label + if (@$stack) + { + @$stack = ( sort { $a cmp $b } @$stack ); + $label .= '|MD/' . join( '/', @$stack ); + } + } + # done applying changes to speciesGraph + + + # Remove dangling edges and rebuild Adjacency hash and Edge array + $g->updateEdges( SpeciesGraph::ALLOW_DANGLING_BONDS, SpeciesGraph::TRIM_DANGLING_BONDS); + + + # Build map of molecules in supergraph to the product patterns they should belong to + # mapP_reverse: product molecules (m) -> product pattern (p) + + # initalize map with an array of zeros (length = number of product molecules plus deleted molecules) + my $mapP_reverse = [ (undef) x (@{$g->Molecules} + @$del_list) ]; + # build map by inverting %mapP for all molecule values. recall thaat mapP: p.m.c -> m.c + while ( my ($pmc, $mc) = each %$mapP ) + { + # skip component pointers + next if ( $mc =~ /\./ ); + # get the pattern index + (my $p) = ($pmc =~ /^(\d+)\./); + # point molecule in supergraph to a product pattern + $mapP_reverse->[$mc] = $p; + } + # splice deleted molecules from mapP_reverse + foreach my $imol (sort {$b <=> $a} @$del_list) + { # do this in reverse order so remaining delete indices remain valid + splice @$mapP_reverse, $imol, 1; + } + # done builing mapP_reverse + + + # Split aggregate graph into connected subgraphs using + # mapP_reverse as a guide to matching the products with patterns. + # On return product graphs will have the same order as the patterns they + # correspond to. Any extra component will be places at the end of the array. + # (this method will not create labels!) + my ($err, $products) = $g->splitConnectedComponents($mapP_reverse); + if ($err) { return (undef, undef); } + + + # return product graph + return ( $products, $label ); +} + + + +### +### +### + + + +# compare two pointers (input arguments are special variables $a and $b) +sub cmp_pointer +{ + # split pointers into elements + my @a = split (/\./, $a); + my @b = split (/\./, $b); + + # set $cmp=0, i.e. no difference found yet + my $cmp = 0; + # loop until break + while (1) + { + # if no elements in pointer A, set cmp=0 if pointer B is empty and -1 otherwise, then break. + unless (@a) { $cmp = @b ? -1 : 0; last; } + # if no elements in pointer B, set cmp=1 + unless (@b) { $cmp = 1; last; } + # shift pointer elements and compare + $cmp = (shift @a <=> shift @b); + # break if we found a difference in these elements + last if $cmp; + } + # return comparison + return $cmp; +} + + +# compare two edges, where an edge has format: "p1.m1.c1,p2.m2.c2" +# note, edge pointers must be sorted prior to comparison! +sub cmp_edge +{ + # split edges into pointer arrays + my @a = split (/,/, $a); + my @b = split (/,/, $b); + + # initialize $cmp=0, i.e. no difference found yet + my $cmp = 0; + # loop until break + while (1) + { + # if no pointers in edge A: set cmp=0 if edge B is empty and -1 otherwise, then break. + unless (@a) { $cmp = @b ? -1 : 0; last; } + # if no pointers in edge B: set cmp=1, then break. + unless (@b) { $cmp = 1; last; } + + # shift pointers and split into elements + my @pa = split (/\./, shift @a); + my @pb = split (/\./, shift @b); + + # loop until break + while (1) + { + # if no elements in pointer A, set cmp=0 if pointer B is empty and -1 otherwise, then break. + unless (@pa) { $cmp = @pb ? -1 : 0; last; } + # if no elements in pointer B, set cmp=1 + unless (@pb) { $cmp = 1; last; } + # shift pointer elements and compare + $cmp = (shift @pa <=> shift @pb); + # break if we found a difference in these elements + last if $cmp; + } + + # break if we found a difference in these pointers + last if $cmp; + } + + # return comparison + return $cmp; +} + + +## +## + + +# converts pointer format (e.g. 0.0.0) to ID format (e.g. "P1_M1_C1" ) +sub pointer_to_ID +{ + my ($id, $pointer) = @_; + + my @names = ( "P", "M", "C" ); + my @arr = split (/\./, $pointer); + if ( $arr[0] == -1 ) + { + $id = "Null"; + } + else + { + $id .= sprintf "%s%d", $names[0], $arr[0] + 1; + foreach my $i ( 1 .. $#arr ) + { $id .= sprintf "_%s%d", $names[$i], $arr[$i] + 1; } + } + return $id; +} + + +## +## + + +sub setRefs +{ + my ($refs, $id, $plist) = @_; + while ( my ($arg,$val) = each %{$refs} ) + { + my $oid = pointer_to_ID( $id . "_R", $val ); + $plist->set( $arg, $oid, 1, "Local" ); + } + return ''; +} + + +sub unsetRefs +{ + my ($refs, $plist) = @_; + foreach my $arg ( keys %{$refs} ) { $plist->deleteLocal($arg); } + return ''; +} + + + +### +### +### + +1; diff --git a/libvcell/vcell_install/bionetgen/Perl2/SBMLMultiAux.pm b/libvcell/vcell_install/bionetgen/Perl2/SBMLMultiAux.pm new file mode 100644 index 0000000..f207cb5 --- /dev/null +++ b/libvcell/vcell_install/bionetgen/Perl2/SBMLMultiAux.pm @@ -0,0 +1,471 @@ +package BNGModel; + +use Storable qw(dclone); +# pragmas +use strict; +use warnings; + +##### +# Extracts a hash containg all the species graphs in the system and enumerates them +##### + + + +sub extractAllSpeciesGraphs +{ + my $model = shift @_; + my $speciesSet = shift @_; + my $speciesTypeSet = shift @_; + + my $speciesCounter = 1; + my $speciesTypeCounter = 1; + + my %print_options = ( + "sbml_multi", "1", + ); + + foreach my $spec (@{$model->SpeciesList->Array}) + { + + $spec->SpeciesGraph->labelHNauty(); + if( !defined $speciesSet->{$spec->SpeciesGraph->StringExact}){ + my $speciesTypeId = 0; + push @{$speciesSet->{$spec->SpeciesGraph->StringExact}}, $speciesCounter; + push @{$speciesSet->{$spec->SpeciesGraph->StringExact}}, $spec->SpeciesGraph; + + # calculate species type and add it to our set as necessary + my $sbmlMultiSpeciesTypeStr = $spec->SpeciesGraph->getMultiSpeciesTypeStr(); + if(exists $speciesTypeSet->{$sbmlMultiSpeciesTypeStr}) + { + $speciesTypeId = $speciesTypeSet->{$sbmlMultiSpeciesTypeStr}; + } + else + { + push @{$speciesTypeSet->{$sbmlMultiSpeciesTypeStr}}, $speciesTypeCounter; + push @{$speciesTypeSet->{$sbmlMultiSpeciesTypeStr}}, $spec->SpeciesGraph; + $speciesTypeId = $speciesTypeCounter; + $speciesTypeCounter++; + } + + push @{$speciesSet->{$spec->SpeciesGraph->StringExact}}, @{$speciesTypeSet->{$sbmlMultiSpeciesTypeStr}}[0]; + $speciesCounter += 1; + + } + + } + + # observable patterns + if ( @{$model->Observables} ){ + foreach my $obs ( @{$model->Observables} ) + { + foreach my $patt (@{$obs->Patterns}){ + $patt->labelHNauty(); + if (! defined $speciesSet->{$patt->StringExact}){ + my $speciesTypeId = 0; + push @{$speciesSet->{$patt->StringExact}}, $speciesCounter; + push @{$speciesSet->{$patt->StringExact}}, $patt; + # calculate species type and add it to our set as necessary + my $sbmlMultiSpeciesTypeStr = $patt->getMultiSpeciesTypeStr(); + if(exists $speciesTypeSet->{$sbmlMultiSpeciesTypeStr}) + { + $speciesTypeId = $speciesTypeSet->{$sbmlMultiSpeciesTypeStr}; + } + else + { + push @{$speciesTypeSet->{$sbmlMultiSpeciesTypeStr}}, $speciesTypeCounter; + push @{$speciesTypeSet->{$sbmlMultiSpeciesTypeStr}}, $patt; + $speciesTypeId = $speciesTypeCounter; + $speciesTypeCounter++; + } + + push @{$speciesSet->{$patt->StringExact}}, @{$speciesTypeSet->{$sbmlMultiSpeciesTypeStr}}[0]; + $speciesCounter += 1; + } + } + } + } + + + foreach my $rset ( @{$model->RxnRules} ) + { + + foreach my $rr ( @$rset ) + { + foreach my $reactant (@{$rr->Reactants}) + { + $reactant->labelHNauty(); + + + if (! defined $speciesSet->{$reactant->StringExact}){ + my $speciesTypeId = 0; + push @{$speciesSet->{$reactant->StringExact}}, $speciesCounter; + push @{$speciesSet->{$reactant->StringExact}}, $reactant; + # calculate species type and add it to our set as necessary + my $sbmlMultiSpeciesTypeStr = $reactant->getMultiSpeciesTypeStr(); + if(exists $speciesTypeSet->{$sbmlMultiSpeciesTypeStr}) + { + $speciesTypeId = $speciesTypeSet->{$sbmlMultiSpeciesTypeStr}; + } + else + { + push @{$speciesTypeSet->{$sbmlMultiSpeciesTypeStr}}, $speciesTypeCounter; + push @{$speciesTypeSet->{$sbmlMultiSpeciesTypeStr}}, $reactant; + $speciesTypeId = $speciesTypeCounter; + $speciesTypeCounter++; + } + + push @{$speciesSet->{$reactant->StringExact}}, @{$speciesTypeSet->{$sbmlMultiSpeciesTypeStr}}[0]; + $speciesCounter += 1; + } + } + foreach my $product (@{$rr->Products}) + { + $product->labelHNauty(); + + + + + if (! defined $speciesSet->{$product->StringExact}){ + my $speciesTypeId = 0; + push @{$speciesSet->{$product->StringExact}}, $speciesCounter; + push @{$speciesSet->{$product->StringExact}}, $product; + + # calculate species type and add it to our set as necessary + my $sbmlMultiSpeciesTypeStr = $product->getMultiSpeciesTypeStr(); + if(exists $speciesTypeSet->{$sbmlMultiSpeciesTypeStr}) + { + $speciesTypeId = $speciesTypeSet->{$sbmlMultiSpeciesTypeStr}; + } + else + { + push @{$speciesTypeSet->{$sbmlMultiSpeciesTypeStr}}, $speciesTypeCounter; + push @{$speciesTypeSet->{$sbmlMultiSpeciesTypeStr}}, $product; + $speciesTypeId = $speciesTypeCounter; + $speciesTypeCounter++; + } + + push @{$speciesSet->{$product->StringExact}}, @{$speciesTypeSet->{$sbmlMultiSpeciesTypeStr}}[0]; + + $speciesCounter += 1; + } + + } + } + } + +} + + +#### +## Walks through the list of species graph in the system and extracts binding components +#### +sub extractBindingComponents +{ + my $model = shift @_; + my $speciesSet = shift @_; + my $bindingComponents_ref = shift @_; + + foreach my $speciesStr (keys %{$speciesSet}){ + my $sg = $speciesSet->{$speciesStr}[1]; + foreach my $mol (@{$sg->Molecules}){ + foreach my $comp (@{$mol->Components}){ + if (@{$comp->Edges}){ + $bindingComponents_ref->{$mol->Name}->{$comp->Name} = 1; + } + #elsif(defined($comp->State) and $bindingComponents_ref->{$mol->Name}->{$comp->Name} != 1){ + # $bindingComponents_ref->{$mol->Name}->{$comp->Name} = -1; + #} + + #elsif(! defined($comp->State) and $bindingComponents_ref->{$mol->Name}->{$comp->Name} != 1 and $bindingComponents_ref->{$mol->Name}->{$comp->Name} != -1){ + # $bindingComponents_ref->{$mol->Name}->{$comp->Name} = 0; + #} + + } + + } + } + +} + +##### +# print sbml and sbml multi parameters and observables +##### +sub writeSBMLParameters +{ + my $model = shift @_; + my $paramHash = shift @_; + my $plist = $model->ParamList; + my $SBML = ''; + + # 3. Parameters + # A. Rate constants + $SBML .= " \n"; + if ($plist->countType('Constant')){ + $SBML .= " \n"; + foreach my $param ( @{$plist->Array} ) + { + $paramHash->{$param->Name} = $param->evaluate([], $plist); + next unless ( $param->Type eq 'Constant' ); + $SBML .= sprintf(" \n", $param->Name, $param->evaluate([], $plist)); + } + } + if ($plist->countType('ConstantExpression')){ + $SBML .= " \n"; + foreach my $param ( @{$plist->Array} ) + { + next unless ( $param->Type eq 'ConstantExpression' ); + $SBML .= sprintf(" \n", $param->Name); + } + } + + # B. Observables + if ( @{$model->Observables} ) + { + $SBML .= " \n"; + foreach my $obs ( @{$model->Observables} ) + { + $SBML .= sprintf(" \n", $obs->Name); + } + } + + # C. Global functions + if ($plist->countType('Function')){ + $SBML .= " \n"; + foreach my $param ( @{$plist->Array} ) + { + next unless ( $param->Type eq 'Function'); + next if ( @{$param->Ref->Args} ); # Don't print local functions + $SBML .= sprintf(" \n", $param->Name); + } + } + + $SBML .= " \n"; + + + # 3.5. Initial assignments (for dependent variables) + if ($plist->countType('ConstantExpression')){ + $SBML .= " \n"; + $SBML .= " \n"; + foreach my $param ( @{$plist->Array} ) + { + # next if ( $param->Expr->Type eq 'NUM' ); + next unless ( $param->Type eq 'ConstantExpression'); + $SBML .= sprintf(" \n", $param->Name); + #print $SBML " \n"; + #print $SBML " \n"; + #$SBML .= sprintf " %s=%s\n", $param->Name,$param->toString($plist); + #print $SBML " \n"; + #print $SBML " \n"; + $SBML .= sprintf($param->toMathMLString( $plist, " " )); + $SBML .= " \n"; + } + $SBML .= " \n"; + } + + return $SBML; +} + +# needs to be modified to iterate over rules instead of reactions +sub writeSBMLReactions +{ + + my $model = shift @_; + my $speciesIdHash_ref = shift @_; + my $SBML = ''; + my %print_options = ( + "sbml_multi", "1", + ); + + # 5. Reactions + $SBML .= " \n"; + my $index = 0; + foreach my $rset ( @{$model->RxnRules} ) + { + foreach my $rxn ( @$rset ) + { + #keeps track of the species components ids that we will use in this reaction mapping + + + $rxn->findMap($model->MoleculeTypesList); + ++$index; + + $SBML .= sprintf " \n", $index, $rxn->toString(); + + #Get indices of reactants + my @rindices = (); + foreach my $spec ( @{$rxn->Reactants} ) + { + my $rid = $speciesIdHash_ref->{'Species'}->{$spec->StringExact}; + $rid = substr($rid, 1, length($rid)); + + push @rindices, $rid #$spec->Index; + } + #@rindices = sort { $a <=> $b } @rindices; + + #Get indices of products + my @pindices = (); + foreach my $spec ( @{$rxn->Products} ) + { + my $pid = $speciesIdHash_ref->{'Species'}->{$spec->StringExact}; + $pid = substr($pid, 1, length($pid)); #extract the id without the 'S' + + push @pindices, $pid #$spec->Index; + + } + #@pindices = sort { $a <=> $b } @pindices; + + #define a reaction hash that contains a speciesIdHash clone corresponding to each reactant in the list + my %reactantHashHash; + my $localCounter = 0; + + if (scalar(@rindices) > 0){ + $SBML .= " \n"; + foreach my $i (@rindices) + { + $SBML .= sprintf " \n", $index,$localCounter+1, $i; + $reactantHashHash{$localCounter}{'id'} = sprintf("RR%d_R%d",$index,$localCounter+1); + $reactantHashHash{$localCounter}{'sg'} = \%{dclone(\%{$speciesIdHash_ref->{'References'}})}; + $localCounter += 1; + } + $SBML .= " \n"; + } + + + if (scalar(@pindices) > 0){ + $SBML .= " \n"; + my $dots; + my $target; + my $sfirstdot; + my $tfirstdot; + my $counter = 0; + foreach my $i (@pindices) + { + + my %productHash = %{dclone(\%{$speciesIdHash_ref->{'References'}})}; + + #FIXME: If i want to be efficient i should be constructing this outside of the loop and making a + #hash containg this information + my $tmpSBML = ''; + foreach my $source ( sort keys %{ $rxn->MapF } ) + { + + my $dots = $source =~ tr/././; #number of dots + + #molecule information (2 dots is for component information) + if($dots == 1){ + + my $target = $rxn->MapF->{$source}; + + my $sfirstdot = index($source, "."); + my $smolecule = substr($source, $sfirstdot+1, length($source)); + $source = substr($source, 0, $sfirstdot); + + + my $tfirstdot = index($target, "."); + my $tmolecule = substr($target, $sfirstdot+1, length($target)); + + $target = substr($target, 0, $tfirstdot); + unless ($target =~ /^\d+?$/) { + next; + } + if($target == $counter){ + + my $rspeciesType; + my $pspeciesType; + + #the species graph for the reactant-product graph pattern pair + my $reactant = @{$rxn->Reactants}[$source]; + my $product = @{$rxn->Products}[$target]; + my $indent4 = " "; + my $sbmlMultiSpeciesTypeStr = $reactant->getMultiSpeciesTypeStr(); #toString(1, 1, \%print_options); + my $psbmlMultiSpeciesTypeStr = $product->getMultiSpeciesTypeStr(); #toString(1, 1, \%print_options); + my $rreverseReference; + my $preverseReference; + my $reactantId = $reactantHashHash{$source}{'id'}; + #get the multi species type id associated with this graph pattern + if(scalar(@{$reactant->Molecules}) > 1){ + $rspeciesType = $speciesIdHash_ref->{'SpeciesType'}->{$sbmlMultiSpeciesTypeStr}; + + #get the species hash associated with this reatant element + my $reactantHash = $reactantHashHash{$source}{'sg'}; + + my $reactantName = @{$reactant->Molecules}[$smolecule]->Name; + + # fixme: this shouldnt be zero, we should actually index the component we want, important if there are labels that change mapping order + # that said, the index here is a $local$ index within the repeated elements of the same molecule type in a species + #get the sbml multi id associated with this graph pattern's component id in the species type + + $rreverseReference = "cmp_" . $reactantHash->{$rspeciesType}{'moleculeReverseReferences'}{$reactantName}[0]; + + #fixme: once again it is not necessarely the first one that we are removing + #we used this component so remove it from the available components pool + splice(@{$reactantHash->{$rspeciesType}{'moleculeReverseReferences'}{$reactantName}}, 0, 1); + } + else{ + $rreverseReference = $speciesIdHash_ref->{'Molecules'}->{@{$reactant->Molecules}[0]->Name}; + } + + if(scalar(@{$product->Molecules}) > 1){ + $pspeciesType = $speciesIdHash_ref->{'SpeciesType'}->{$psbmlMultiSpeciesTypeStr}; + my $productName = @{$product->Molecules}[$tmolecule]->Name; + $preverseReference = "cmp_" . $productHash{$pspeciesType}{'moleculeReverseReferences'}{$productName}[0]; + splice(@{$productHash{$pspeciesType}{'moleculeReverseReferences'}{$productName}}, 0, 1); + } + else{ + $preverseReference = $speciesIdHash_ref->{'Molecules'}->{@{$product->Molecules}[0]->Name}; + + } + + + #use Data::Dumper; + #print Dumper $reactantHashHash{$source}{'sg'},'...'; + + + + $tmpSBML .= sprintf "${indent4}\n"; + + } + + + + } + } + + unless ($tmpSBML eq ''){ + $SBML .= sprintf " \n", $index, $counter+1, $i; + $SBML .= sprintf " \n"; + $SBML .= $tmpSBML; + $counter += 1; + $SBML .= sprintf " \n"; + $SBML .= " \n"; + + } + else{ + $SBML .= sprintf " \n", $index, $counter+1, $i; + } + + + } + $SBML .= " \n"; + } + + $SBML .= " \n"; + my ( $rstring, $err ) = $rxn->RateLaw->toMathMLString( \@rindices, \@pindices); + if ($err) { return $err; } + + foreach my $line ( split "\n", $rstring ) + { + $SBML .= " $line\n"; + } + $SBML .= " \n"; + + $SBML .= " \n"; + } + + } + $SBML .= " \n"; + return $SBML; +} + +1; + diff --git a/libvcell/vcell_install/bionetgen/Perl2/Species.pm b/libvcell/vcell_install/bionetgen/Perl2/Species.pm new file mode 100644 index 0000000..acc2190 --- /dev/null +++ b/libvcell/vcell_install/bionetgen/Perl2/Species.pm @@ -0,0 +1,242 @@ +package Species; + +# pragmas +use strict; +use warnings; + +# Perl Modules +use Class::Struct; +use FindBin; +use lib $FindBin::Bin; + +# BNG Modules +use SpeciesGraph; + + + +struct Species => +{ + SpeciesGraph => 'SpeciesGraph', + Concentration => '$', # this will either be a number or a parameter name (I think) + Index => '$', + RulesApplied => '$', + ObservablesApplied => '$', +}; + + + +### +### +### + + +sub toXML +{ + my $spec = shift @_; + my $indent = @_ ? shift @_ : ""; + my $conc = @_ ? shift @_ : $spec->Concentration; + my $id = @_ ? shift : "S".$spec->Index; # what's this for?? + + my $type = 'Species'; + my $attributes = ''; + + # Attributes + # concentration + $attributes .= " concentration=\"" . $conc . "\""; + # name + $attributes .= " name=\"" . $spec->SpeciesGraph->toString() . "\""; + + # Objects contained + my $string = $spec->SpeciesGraph->toXML($indent,$type,$id,$attributes); + + return $string; +} + +### +### +### + + +sub toSBMLMulti +{ + my $spec = shift @_; + my $indent = @_ ? shift @_ : ""; + my $id = @_ ? shift : "S".$spec->Index; + my $conc = @_ ? shift @_ : $spec->Concentration; + + + my $type = 'species'; + my $attributes = ''; + + # Attributes + # concentration + $attributes .= " concentration=\"" . $conc . "\""; + # name + $attributes .= " name=\"" . $spec->SpeciesGraph->toString() . "\""; + + # Objects contained + my $string = $spec->SpeciesGraph->toSBMLMultiSpecies($indent,$type,$id,$attributes); + + return $string; +} + +sub toSBMLMultiType +{ + my $spec = shift @_; + my $mtlist = shift @_; + my $indent = @_ ? shift @_ : ""; + my $sbmlMultiSpeciesInfo_ref = shift @_; + + my $id = @_ ? shift : "ST".$spec->Index; + + my $type = 'multi:speciesType'; + my $attributes = ''; + + + my $string = $spec->SpeciesGraph->toSBMLMultiSpeciesType($mtlist, $indent,$type,$id,$sbmlMultiSpeciesInfo_ref); + + + + return $string; + +} + +### +### +### +### +### +### + +################DB######################### +sub writeMDL +{ + my $spec = shift @_; + my $difexp = @_ ? shift @_ : {}; + my $py_species = @_ ? shift @_ : []; + my $indent = " "; + my $py_string = ""; + my $string = "s".$spec->Index." /* ".$spec->SpeciesGraph->toString()." */"; + my $comp = $spec->SpeciesGraph->Compartment ? $spec->SpeciesGraph->Compartment : undef; + my ($difconst, $cdimension) = (defined $comp) ? ($difexp->{$comp}, $comp->SpatialDimensions) : ($difexp->{"DEFAULT"}, 3); + + if (defined $comp && $comp->SpatialDimensions == 2){ + my $count = (scalar @{$spec->SpeciesGraph->Molecules}) - ($spec->SpeciesGraph->toString() =~ tr/@//) + 1; # Number of membrane molecules in species + my $radius = ($count == 1) ? "Rsp" : "SQRT(".$count.")*Rsp"; + $difconst =~ s/Rsp/$radius/g; + $difconst =~ s/Rsp/Rc/g; + } + else{ + my $radius = (scalar @{$spec->SpeciesGraph->Molecules} == 1) ? "Rsp" : "(".scalar @{$spec->SpeciesGraph->Molecules}.")^(1/3)*Rsp"; + $difconst =~ s/Rsp/$radius/g; + $difconst =~ s/Rsp/Rs/g; + } + + $string .= "\n"; + $string .= $indent."{\n"; + $string .= $indent.$indent.sprintf("DIFFUSION_CONSTANT_%dD = %s\n", $cdimension, $difconst); + $string .= $indent."}\n"; + + $py_string = "{"; + #$py_string .= "'name':"."'s".$spec->Index." /* ".$spec->SpeciesGraph->toString()."* /',"; + $py_string .= "\"name\":"."\"s".$spec->Index."\","; + $py_string .= "\"type\":"."\"".sprintf("%dD",$cdimension)."\","; + $py_string .= "\"dif\":"."\"".sprintf("%s", $difconst)."\"," ; + $py_string .= "\"extendedName\":"."\"".sprintf("%s", $spec->SpeciesGraph->toString())."\""; + $py_string .= "}"; + + push(@{$py_species},$py_string); + + return $string; +} + +################DB######################### +### +### +### + +###############DB########################## +sub getMDLRelSite +{ + my $sp = shift; + my $object = shift; + my $shape = shift; + my $custom_geometry = shift; + + my $comp; + my $site = []; + $site = ($comp = $sp->SpeciesGraph->Compartment) ? $comp->getMDLRelSite() : undef; + + my $string; + my $i = 1; + if (defined $site){ + foreach (@{$site}){ + if ($custom_geometry){ + if ($comp->SpatialDimensions == 2){ + $string .= "Scene.".$shape->{$_}; + } + elsif (($comp->SpatialDimensions == 3)&&(!@{$comp->Inside})){ + $string .= "Scene.".$object->{$_}; + } + else{ + $string .= $i ? "Scene.".$shape->{$object->{$_}} : " - Scene.".$shape->{$object->{$_}}; + } + } + else{ + $string .= $i ? (@{$comp->Inside} ? "Scene.".$shape->{$_}: "Scene.".$object->{$_}) : " - Scene.".$shape->{$_}; + } + $i = 0; + } + } + else{ + $string = "Scene."."default_Sphere"; + } + + return $string; + +} + +### +### +### + +sub getCVodeName +{ + my $species = shift; + my $offset = -1; + return 'NV_Ith_S(species,' . ($species->Index + $offset). ')'; +} + +sub getCVodeDerivName +{ + my $species = shift; + my $offset = -1; + return 'NV_Ith_S(Dspecies,' . ($species->Index + $offset). ')'; +} + + +### +### +### + + +sub getMatlabName +{ + my $species = shift; + my $offset = 0; + return 'species(' . ($species->Index + $offset). ')'; +} + +sub getMatlabDerivName +{ + my $species = shift; + my $offset = 0; + return 'Dspecies(' . ($species->Index + $offset). ')'; +} + + +### +### +### + +1; diff --git a/libvcell/vcell_install/bionetgen/Perl2/SpeciesGraph.pm b/libvcell/vcell_install/bionetgen/Perl2/SpeciesGraph.pm new file mode 100644 index 0000000..218984d --- /dev/null +++ b/libvcell/vcell_install/bionetgen/Perl2/SpeciesGraph.pm @@ -0,0 +1,3653 @@ +package SpeciesGraph; + +# pragmas +use strict; +use warnings; +no warnings 'redefine'; + +# Perl Modules +use Class::Struct; +use FindBin; +use lib $FindBin::Bin; +use List::Util qw(min max sum); +use Storable qw(dclone); +#use List::MoreUtils qw(first_index); + +# BNG Modules +use Molecule; +use Component; +use Compartment; +use BNGUtils; +use Map; +use MoleculeTypesList; +use HNauty; + +# constants +use constant { PRINT_EDGES => 1, + PRINT_ATTRIBUTES => 1, + ALLOW_DANGLING_BONDS => 1, + TRIM_DANGLING_BONDS => 1, + IS_SPECIES => 1, + COPY_LABEL => 1, + GET_LABEL => 1, + TRUE => 1, + FALSE => 0, + }; + + +struct SpeciesGraph => +{ + Name => '$', + Label => '$', # Local variable to assign to this Object (analogous to Label atrribute of Moleules + # and Components, not to be confused with graph label) + Compartment => 'Compartment', + Molecules => '@', + Edges => '@', # an array whose only element is an array of edge definitions (why a 2d array?) + Adjacency => '%', + StringID => '$', # This is for the Canonical label. + StringExact => '$', # This is also related to canonical labeling (what's the difference?) --justin + Quantifier => '$', + Species => 'Species', # Set only if this SpeciesGraph is bound to a particular Species + MatchOnce => '$', # Map this pattern at most 1 time to a given species + Fixed => '$', # Concentration of species referred to by this pattern is constant. + IsCanonical => '$', + Automorphisms => '$' +}; + + + +# Set default species label method: +# Allowed values are Auto, HNauty, Quasi. +my $SpeciesLabel = 'Auto'; +my $SpeciesLabel_MaxMols = 0; + + + +### +### +### +#copied from list::moreutils since it doesnt come standard +sub first_index (&@) { + my $f = shift; + foreach my $i ( 0 .. $#_ ) { + local *_ = \$_[$i]; + return $i if $f->(); + } + return -1; +} + +sub getMultiSpeciesTypeStr +{ + my $speciesGraph = shift @_; + my $sg = dclone($speciesGraph); + + foreach my $molecule (@{$sg->Molecules}) + { + my @multistcomponents = (); + foreach my $comp (@{$molecule->Components}) + { + my $componentFlag = 0; + if (defined $comp->Edges ) + { + + foreach my $edge (@{$comp->Edges}) + { + if ($edge=~ /^\d+$/) + { + $componentFlag = 1; + last; + } + } + } + else{ + print $comp->toString(); + } + + if($componentFlag) + { + if(defined $comp->State){ + $comp->State(undef); + } + push @multistcomponents, $comp; + } + + } + $molecule->Components(\@multistcomponents); + + } + $sg->labelHNauty(); + return $sg->StringExact; +} + + + +# set the method used to generate SpeciesGraph Lables +# HNauty == canonical labeling via HNauty method +# Auto == quasi-canonical labeling with isomorphism checks similar graphs +# Quasi == quasi-canonical labeling, no checks (unsafe method) +sub setSpeciesLabel +{ + my $label = shift @_; + my $maxmols = @_ ? shift @_ : 0; + my %valid = ('Auto' => 1, 'HNauty' => 1, 'Quasi' => 1); + if ( defined $valid{$label} ) + { + if ($SpeciesLabel ne $label) + { + $SpeciesLabel = $label; + print "SpeciesLabel method set to $label.\n"; + } + } + else + { + return "Invalid value for SpeciesLabel function: $label"; + } + + if ($SpeciesLabel_MaxMols != $maxmols) + { + $SpeciesLabel_MaxMols = $maxmols; + printf "SpeciesLabel max molecule threshold set to %.0f.\n", $maxmols; + if ($maxmols > 0) + { send_warning(sprintf "Species with more than %.0f molecules will be labeled with the Quasi method.", $maxmols) } + elsif ($maxmols <= 0) + { printf " (all species will be labeled with the %s method)\n", $SpeciesLabel; } + } + + return ''; +} + +# get species label method +sub getSpeciesLabelMethod +{ + return $SpeciesLabel; +} +# get species label max molecules +sub getSpeciesLabelMethod_MaxMols +{ + return $SpeciesLabel_MaxMols; +} + + +### +### +### + +# check if this is a null speciesGraph +sub isNull +{ + my $sg = shift @_; + return @{$sg->Molecules} ? 0 : 1; +} + + +# get string for the null pattern +sub getNullString +{ + return "0"; +} + + + +### +### +### + + + +sub readString +{ + my $sg = shift @_; + my $strptr = shift @_; + my $clist = shift @_; + my $is_species = shift @_; + my $stop = shift @_; + my $mtlist = shift @_; + # should we count the number of automorphisms? (do this for molecule observables!) + my $CountAutos = (@_) ? shift : FALSE; + + # holds error for return value + my $err = undef; + + # get string and remove leading whitespace + my $string_left = $$strptr; + $string_left =~ s/^\s+//; + + # check for premature termination + if ( !$string_left or ($stop and $string_left =~ /$stop/) ) + { return "Expecting SpeciesGraph but found termination characters instead\n" + ." in string '$string_left'."; + } + + # check for the null pattern + if ( $string_left =~ /^0($|\s|\+|<->|->|,)/ ) + { # This is the null pattern. Strip pattern and return. + $string_left =~ s/^0//; + $$strptr = $string_left; + return $err; + } + + # Header (all characters up to ":") + # restrict pre ":" characters to word characters, whitespace, "%", "*" and "@", + # QUESTION: should white space be disallowed since it is the stop character after product patterns? + if ( $string_left =~ s/^([\w\s%@*]+)(::|:)\s*// ) + { + my $head = $1; + + # Optional species name + # COMMENT: why is "*" allowed in a Name? +# if ( $head =~ s/^([\w\s*]+)// ) { $sg->Name($1); } + if ( $head =~ s/^(\w+)\s*// ) { $sg->Name($1); } + + # Optional Label (variable tag name) + if ( $head =~ s/^\%(\w+)// ) { $sg->Label($1); } + + # Optional species compartment + if ( $head =~ s/^\@(\w+)// ) + { + my $comp = $clist->lookup($1); + if ($comp) { $sg->Compartment($comp); } + else { return ("Undefined compartment $1"); } + } + if ($head) + { + return "Improper syntax for SpeciesGraph header at $head"; + } + } + + # check for premature termination + if ( !$string_left or ($stop and $string_left =~ /$stop/) ) + { return "Expecting SpeciesGraph but found termination characters instead\n" + ." in string '$string_left'."; + } + + # parse molecules + while ($string_left) + { + # Handle continuation and stopping + # molecule separator characters + next if ( $string_left =~ s/^\.// ); + last if ( $stop and $string_left =~ /$stop/ ); + + # Handle modifier syntax + if ( $string_left =~ s/^\$// ) + { # Set Fixed attribute + $sg->Fixed(1); + } + elsif ( $string_left =~ s/^(=|==|<|<=|>|>=)(\d+)// ) + { # Quantifier + my $op = $1; + if ( $op eq '=' ) { $op = '==' } + $sg->Quantifier( $op . $2 ); + # AS2023 - we need to check if we have multiple quantifiers in the pattern + if (not $string_left =~ /^(\s|,)/ ) { + # AS2023 - this means what we have left doesn't start with a space + # or a "," meaning that this is not a properly separated pattern + if ( $string_left =~ s/(=|==|<|<=|>|>=)(\d+)// ) { + return "Can't have multiple quantifiers in pattern."; + } + } + + if ($is_species) { return "Quantifier not allowed in species"; } + } + elsif ( $string_left =~ s/^[{]// ) + { # Attributes listed in {} + while ( !( $string_left =~ s/^\}// ) ) + { + my $attr = ''; + my $value = ''; + + # Get attribute name + if ( $string_left =~ s/^([^,=\}]+)// ) { $attr = $1; } + else + { + return "Null attribute for SpeciesGraph at $string_left"; + } + + # Get (optional) attribute value + if ( $string_left =~ s/^=([^,\}]+)// ) { $value = $1; } + + # Remove trailing comma + $string_left =~ s/^,//; + + if ( $attr eq 'MatchOnce' ) + { + if ($is_species) + { + return "MatchOnce is not a valid attribute for a species."; + } + my $val = booleanToInt($value); + if ( $val == -1 ) + { + return "Invalid value $value assigned to Boolean attribute $attr"; + } + $sg->MatchOnce($val); + } + elsif ( $attr eq 'Fixed' ) + { + my $val = booleanToInt($value); + if ( $val == -1 ) + { + return "Invalid value $value assigned to Boolean attribute $attr"; + } + $sg->Fixed($val); + } + else { return "Invalid attribute $attr for SpeciesGraph"; } + } + } + else + { + # Read molecule + my ($mol, $err) = Molecule::newMolecule( \$string_left, $clist ); + if ( $err ) { return $err; } + + push @{$sg->Molecules}, $mol; + } + } + + + # Check edge labels for correct definition + # Sorts molecules and components and contructs edges an adjacency matrix. + if ($is_species) + { + # a real species cannot be null! + unless ( @{$sg->Molecules} ) + { return "The empty graph is not a valid species in $$strptr"; } + + if ($clist->Used) + { + # assign species compartment (if possible) + $err = $sg->assignCompartment(); + return $err if ($err); + + # Check for defined compartment assignment + unless ( defined $sg->Compartment ) + { return "Species does not have a compartment attribute!"; } + + # Check for valid bonds + unless ( $sg->verifyTopology(1) ) + { return "Species has invalid bonds with respect to Compartment topology."; } + } + + # NOTE: sortLabel sorts the molecules in a canonical or semi-canonical fashion, + # in the process the edges are updated (so no need to call updateEdges here!) + if ( $err = $sg->sortLabel() ) { return $err; } + + # Check for correct number of subgraphs + my ($nsub) = $sg->findConnected(); + unless ( $nsub == 1 ) + { return "Species $$strptr is not connected"; } + } + else + { + $err = $sg->updateEdges(); + # $err = $sg->updateEdges( ALLOW_DANGLING_BONDS ); #Uncomment this line to allow dangling bonds + if ($err) { return $err; } + } + + # Check that molecules match declared types + if ($mtlist) + { + $err = $mtlist->checkSpeciesGraph( $sg, { IsSpecies => $is_species, + AllowNewTypes => !$mtlist->StrictTyping } ); + if ($err) { return $err; } + } + + # count automorphisms + if ( $CountAutos ) + { + my @autos = $sg->isomorphicToSubgraph($sg); + $sg->Automorphisms( scalar @autos ); + } + + $$strptr = $string_left; + return $err; +} + + + +### +### +### + + + +# check if a speciesGraph represents a fully-specified species. +# TODO: need to check that compartments are specified, if we're using compartments! +sub checkSpecies +{ + my $sg = shift @_; + my $model = shift @_; + + my $err; + my $comp; + my $params = { IsSpecies => 1, + AllowNewTypes => 0 }; + + # check that components are fully specified + $err = $model->MoleculeTypesList->checkSpeciesGraph( $sg, $params ); + return 0 if ($err); + + # check compartment validity + ($comp, $err) = $sg->inferSpeciesCompartment(); + return 0 if ($err); + + # everything checks out! this is a species + return 1; +} + + + +### +### +### + + +# Convert a pointer to a SpeciesGraph component or molecule to a label (used in XML output) +sub p_to_label +{ + my $sg = shift; + my $p = shift; + my $string = shift; + + my @inds = split( '\.', $p ); + + if ( $#inds == 0 ) { + $string .= sprintf "_M%d", ( $inds[0] + 1 ); + } + elsif ( $#inds == 1 ) { + $string .= sprintf "_M%d_C%d", ( $inds[0] + 1 ), $inds[1] + 1; + } + else { + die "Error in p_to_label"; + } + + return ($string); +} + +sub p_to_multi_label +{ + my $sg = shift @_; + my $p = shift @_; + my $speciesIdHash_ref = shift @_; + my $stid = shift @_; + + my @inds = split( '\.', $p ); + my $fullstring = sprintf("%s(%s)", @{$sg->Molecules}[$inds[0]]->Name, @{@{$sg->Molecules}[$inds[0]]->Components}[$inds[1]]->Name); + + my $multiid = sprintf "ST${stid}_M%d_C%d" , ($inds[0]+1) , $inds[1] + 1; + + + #print Dumper $speciesIdHash_ref; + #my $mid = sprintf("ST%s_M%d",$stid,$p+1); + #foreach my $comp (@{$speciesIdHash_ref->{'reverseReferences'}->{$fullstring}}){ + # if (index($comp, $mid) != -1){ + # return $speciesIdHash_ref->{'Components'}->{$comp}->{'id'}; + # } + # } + return $speciesIdHash_ref->{'Components'}->{$multiid}->{'id'}; + +} + +### +### +### + + + +sub labelHNauty +{ + use strict; + use Data::Dumper; + + my $sg = shift @_; + my $allow_dangling = @_ ? shift @_ : 0; + my $trim_dangling = @_ ? shift @_ : 0; + + # holds error value for return + my $err; + + # Construct adjacency matrix and partition + my %adj = (); + my @partition = (); + + # Contains partitions for molecules + my %mtypes = (); + + # Contains partitions for components + my %ctypes = (); + + # Hash to convert pointers to node index + my %pointer_index = (); + + # Bonds hashed by name + my %bonds = (); + + my $n_mol = scalar( @{ $sg->Molecules } ); + my $imol = 0; + my $icomp = $n_mol; + + # Loop over molecules and components to + # (1) determine pointer to index conversions + # (2) partition by Molecule and Componoent names (could add connectivity later, if it improves performance) + # (3) create edges from Molecules to its contained Components + # (4) collect bonds in a hash (precludes need to call update edges beforehand). + foreach my $mol ( @{$sg->Molecules} ) + { + $pointer_index{$imol} = $imol; + + my $bond_wildcard = ''; + foreach my $edge ( @{$mol->Edges} ) + { + if ($edge =~ /(\+|\?|\-)/) + { $bond_wildcard = $1; } + else + { push @{$bonds{$edge}}, $imol; } + } + + my $mname = join( ".", $mol->Name, + defined $mol->State ? $mol->State : '', + $bond_wildcard, + defined $mol->Compartment ? $mol->Compartment : '' + ); + + push @{ $mtypes{$mname} }, $imol; + + my $jcomp = 0; + foreach my $comp ( @{$mol->Components} ) + { + my $ptr = "$imol.$jcomp"; + $pointer_index{$ptr} = $icomp; + + my $bond_wildcard = ''; + foreach my $edge ( @{$comp->Edges} ) + { + if ($edge =~ /(\+|\?|\-)/) + { $bond_wildcard = $1; } + else + { push @{$bonds{$edge}}, $ptr; } + } + + my $cname = join( ".", $mname, + $comp->Name, + defined $comp->State ? $comp->State : '', + $bond_wildcard, + defined $comp->Compartment ? $comp->Compartment : '' + ); + + push @{ $ctypes{$cname} }, $icomp; + + $adj{$imol}{$icomp} = [0]; + $adj{$icomp}{$imol} = [0]; + + ++$icomp; + ++$jcomp; + } + ++$imol; + } + + # Loop over Edges to determine adjacency matrix for bonds + foreach my $ename ( keys %bonds ) + { + my $earr = $bonds{$ename}; + my $istart = $pointer_index{ $$earr[0] }; + my $iend = $pointer_index{ $$earr[1] }; + $adj{$istart}{$iend} = [1]; + $adj{$iend}{$istart} = [1]; + } + + # Set up partitions; sort order molecules then components. + foreach my $type ( sort keys %mtypes ) + { + push @partition, $mtypes{$type}; + } + foreach my $type ( sort keys %ctypes ) + { + push @partition, $ctypes{$type}; + } + + # Call HNauty to obtain canonical ordering + ( my $perm ) = HNauty( \%adj, \%adj, \@partition ); + + + # Reorder Components of each Molecule according to canonical order + my $icomp_start = $n_mol; + foreach my $mol ( @{ $sg->Molecules } ) + { + my $icomp_end = $icomp_start + $#{ $mol->Components }; + my @perm_c = map { $perm->{$_} } ( $icomp_start .. $icomp_end ); + + my @comp_perm = map { [ $perm_c[$_], $mol->Components->[$_] ] } ( 0 .. $#{ $mol->Components } ); + @comp_perm = sort { $a->[0] <=> $b->[0] } @comp_perm; + $mol->Components( [ map { $_->[1] } @comp_perm ] ); + $icomp_start = $icomp_end + 1; + } + + # Reorder Molecules according to canonical order + # This is probably inefficient since we have the exact mapping + my @mol_perm = + map { [ $perm->{$_}, $sg->Molecules->[$_] ] } + ( 0 .. $#{ $sg->Molecules } ); + + #map {print $_->[0];} @mol_perm; print "\n"; + @mol_perm = sort { $a->[0] <=> $b->[0] } @mol_perm; + $sg->Molecules( [ map { $_->[1] } @mol_perm ] ); + + # update edges + $err = $sg->updateEdges( $allow_dangling, $trim_dangling ); + if ( $err ) { return $err }; + + # Create exact string representation: include edge labels and strip attributes + # first argument tells "toString" whether to ignore edge labels (true) or not (false) + # second argument tells "toString" whether to strip attributes (true) or not (false) + my $string = $sg->toString( PRINT_EDGES, !PRINT_ATTRIBUTES ); + $sg->StringExact($string); + $sg->StringID($string); + $sg->IsCanonical(TRUE); + + return $err; +} + + + +### +### +### + + + +sub labelQuasi +{ + my $sg = shift; + my $isCanonical = (@_) ? shift : 0; + my $allow_dangling = (@_) ? shift : 0; + my $trim_dangling = (@_) ? shift : 0; + + my $err = undef; + + # Sort components of each molecule + foreach my $mol (@{$sg->Molecules}) + { @{$mol->Components} = sort by_component @{$mol->Components}; } + + # Sort molecules + @{$sg->Molecules} = sort by_molecule @{$sg->Molecules}; + + # update edges after sort! + $err = $sg->updateEdges( $allow_dangling, $trim_dangling ); + if ($err) { return $err; } + + # Create quasi-canonical string representation + $sg->StringID( $sg->toString(!PRINT_EDGES, !PRINT_ATTRIBUTES ) ); + + # Create exact string representation: include edge labels and strip attributes + # first argument tells "toString" whether to ignore edge labels (true) or not (false) + # second argument tells "toString" whether to strip attributes (true) or not (false) + $sg->StringExact( $sg->toString(PRINT_EDGES, !PRINT_ATTRIBUTES) ); + $sg->IsCanonical($isCanonical); + + return $err; +} + + + +### +### +### + + + +# Modified version using different labeling functions +sub sortLabel +{ + my $sg = shift @_; + my $allow_dangling = @_ ? shift @_ : FALSE; + my $trim_dangling = @_ ? shift @_ : FALSE; + + my $err = undef; + if ( ($SpeciesLabel eq 'Quasi') or ($SpeciesLabel_MaxMols and (@{$sg->Molecules} > $SpeciesLabel_MaxMols)) ) + { # Equivalent to setting check_iso=>0 + my $is_canonical = TRUE; + $err = $sg->labelQuasi( $is_canonical, $allow_dangling, $trim_dangling ); + } + elsif ( $SpeciesLabel eq 'Auto' ) + { + my $is_canonical = FALSE; + $err = $sg->labelQuasi( $is_canonical, $allow_dangling, $trim_dangling ); + } + elsif ( $SpeciesLabel eq 'HNauty' ) + { + $err = $sg->labelHNauty( $allow_dangling, $trim_dangling ); + } + + return $err; +} + + + + +### +### +### + + + +sub assignCompartment + # $err = $sg->assignCompartment() + # $err = $sg->assignCompartment( $force_comp ) + # + # Calls inferSpeciesCompartment to determine Species Compartment and then makes + # the assignment, if valid. Returns an error string if there are any problems. + # Note that the assignment is allowed to be undefined! + # + # If $force_comp is supplied, the SpeciesGraph is forced to that compartment, + # unless it is incompatible with any molecule compartments. +{ + my $sg = shift; # SpeciesGraph + my $force_comp = scalar(@_) ? shift : undef; + + # get Species Compartment (return any errors) + my ( $species_comp, $err ) = $sg->inferSpeciesCompartment(); + return $err if ($err); + + if ( defined $force_comp and defined $species_comp ) + { + unless ( $species_comp == $force_comp ) + { + return sprintf "Attempt to force incompatible species compartment on SpeciesGraph %s.", $sg->toString(); + } + } + elsif ( defined $force_comp and !defined($species_comp) ) + { + # set species compartment to the forced value + $species_comp = $force_comp; + } + elsif ( !defined $force_comp and !defined($species_comp) ) + { + # Currently nothing to do here! + # in strict mode: generate error + # return sprintf "Species Compartment for SpeciesGraph %s could not be determined.", + # $sg->toString(); + return ''; + } + + # Assign Compartment + $sg->Compartment($species_comp); + + # Set Compartment of any Molecules without explicit Compartment definitions. + # NOTE: This handles compartment specification when syntax "@C:Species" is used. + foreach my $mol ( @{ $sg->Molecules } ) + { + unless ( defined $mol->Compartment ) + { + $mol->Compartment($species_comp); + } + } + return ''; +} + + + +### +### +### + + + +sub inferSpeciesCompartment +# (Compartment, err) = $sg->inferCompartment() +# +# Infers Species Compartment of a SpeciesGraph. Returns an undefined Compartment +# if the Compartment cannot be inferred or is invalid. Sets err=1 if Species +# Compartment is invalid and err=0 otherwise. +# +# TODO: There is no check for bond validity here! SHould be added in future. +# TODO: What about verifying that all compartments are specified? +{ + my $sg = shift; + + my $inferred_comp; # Species Compartment inferred from molecules + my %volumes = (); # molecule volume compartments found in $sg + my %surfaces = (); # molecule surface compartments found in $sg + my $err = ''; # return error (set string if species compartment is invalid) + + # Gather molecule compartments + foreach my $mol ( @{ $sg->Molecules } ) + { + my $comp = $mol->Compartment; + + # fixed BUG: if compartment molecule isn't explictly defined, + # transfer the explicit species compartment (if any) --justin + if ( !(defined $comp) and defined $sg->Compartment ) + { + $comp = $sg->Compartment; + } + + next unless ( defined $comp ); + + if ( $comp->SpatialDimensions == 2 ) { $surfaces{$comp} = $comp; } + elsif ( $comp->SpatialDimensions == 3 ) { $volumes{$comp} = $comp; } + } + + my $n_surfaces = scalar( keys %surfaces ); + my $n_volumes = scalar( keys %volumes ); + + # infer Species Compartment + if ( $n_surfaces == 0 ) + { + if ( $n_volumes == 0 ) + { # no inferred compartment + $inferred_comp = undef; + } + elsif ( $n_volumes == 1 ) + { # unique volume compartment is inferred + ($inferred_comp) = ( values %volumes ); + } + else #( $n_volumes > 1 ) + { # error: multiple volumes with no surface + $err = + sprintf + "Molecule Compartments of %s define invalid Species Compartment.", + $sg->toString(); + return ( undef, $err ); + } + } + elsif ( $n_surfaces == 1 ) + { # unique surface compartment is inferred + ($inferred_comp) = ( values %surfaces ); + + # check adjacency of volumes + foreach my $comp ( values %volumes ) + { + unless ( $inferred_comp->adjacent($comp) ) + { # error: volume not adjacent to surface + $err = sprintf "Molecule Compartments of %s define invalid Species Compartment.", $sg->toString(); + return ( undef, $err ); + } + } + } + else #( $n_surfaces > 1 ) + { # error: multiple surfaces + $err = sprintf "Molecule Compartments of %s include more than 1 Surface.", $sg->toString(); + return ( undef, $err ); + } + + # Check that inferred Species Compartment assignment is Compatible with any explicit declaration + if ( defined $sg->Compartment and defined $inferred_comp ) + { + unless ( $inferred_comp == $sg->Compartment ) + { + $err = sprintf "Explicit Species Compartment (%s)" + ." is not compatible with inferred Species Compartment (%s)", + $sg->Compartment->Name, $inferred_comp->Name; + return ( undef, $err ); + } + } + + # if no compartment was inferred, then use explicit compartment (if any) + if ( defined $sg->Compartment and !( defined $inferred_comp ) ) + { + $inferred_comp = $sg->Compartment; + } + + # return inferred compartment + return ( $inferred_comp, $err ); +} + + + +### +### +### + + + +sub verifyTopology +# $valid = $sg->verifyTopology( $strict ) +# +# Verifies the topology of a species graph w.r.t. bonds and compartments. +{ + my $sg = shift @_; + my $strict = @_ ? shift @_ : 0; + + # gather pairs of bonded components + my %bonds = (); + foreach my $mol ( @{$sg->Molecules} ) + { + foreach my $component ( @{$mol->Components} ) + { + foreach my $edge_idx ( @{$component->Edges} ) + { push @{ $bonds{$edge_idx} }, $mol; } + } + } + + # check that bound components belong to molecules in same or adjacent compartments + foreach my $bond ( values %bonds ) + { + # fail if there's fewer or greater than 2 components in this bond + return 0 if (@$bond != 2); + + my $comp0 = $bond->[0]->Compartment; + my $comp1 = $bond->[1]->Compartment; + if (defined $comp0 and defined $comp1) + { # Both compartments are defined, check that compartments are the same or adjacent + return 0 unless ( $comp0==$comp1 or $comp0->adjacent($comp1) ); + } + else + { return 0 if ($strict); } + } + return 1; +} + + +### +### +### + + + +# bool = interactingSet ( $sg1, $sg2, .. ) +# +# determine if list of species graphs forms an interacting Set. Return 1 if +# yes, and 0 otherwise. +# +# NOTE: if all species have undefined compartment, then Return 1. But return 0 +# if only some of the species have undefined compartment. This lets us run +# compartmentBNG in a "sloppy" mode where compartments may or may not be defined. +sub interactingSet +{ + my @sgs = @_; + + my $volume = undef; # volume compartment + my $surface = undef; # surface compartment + + # find surface and volume compartments + my $missing = 0; # track species without compartment + foreach my $sg (@sgs) + { + my $comp = $sg->Compartment; + unless ( defined $comp ) + { # species has undefined compartment + $missing++; + next; + } + + if ( $comp->SpatialDimensions == 2 ) + { # this compartment is a surface + if ( defined $surface ) + { # Surface found previously. This surface should be the same. + return 0 unless ( $surface == $comp ); + } + else + { # No surface found previously. + $surface = $comp; + } + } + elsif ( $comp->SpatialDimensions == 3 ) + { # this compartment is a volume + if ( defined $volume ) + { # Volume found previously. This volume should be the same. + return 0 unless ( $volume == $comp ); + } + else + { # No volume found previously. + $volume = $comp; + } + } + } + + if ( defined $surface and defined $volume ) + { # surface and volume must be adjacent + return 0 unless ( $surface->adjacent($volume) ); + } + + if ( $missing and ($missing < @sgs) ) + { # mixture of reactants with and without compartment + return 0; + } + + # species are an interacting set! + return 1; +} + + + + +# @compartment_connected = $sg->find_compartment_connected( $i_mol ) +# +# find the set of molecules in $sg that are connected to the molecule $i_mol by +# a path contained in the same compartment as $i_mol. Returns a list of +# indexes corresponding to the molecules in the set. +sub find_compartment_connected +{ + my ($sg, $i_mol) = @_; + + # get compartment of reference molecule + my $comp = $sg->Molecules->[$i_mol]->Compartment; + return () unless ( defined $comp ); + + # build a hash that maps each molecule in compartment to the set + # of adjacent vertices (also in the compartment) + my $adjacency_hash = {}; + foreach my $edge ( @{ $sg->Edges } ) { + my ( $mol1, $mol2 ) = ( $edge =~ /^(\d+)\.\d+\s+(\d+)\.\d+/ ); + if ( $sg->Molecules->[$mol1]->Compartment == $comp + and $sg->Molecules->[$mol2]->Compartment == $comp ) + { + push @{ $adjacency_hash->{$mol1} }, $mol2; + push @{ $adjacency_hash->{$mol2} }, $mol1; + } + } + + # initialize hash map for collection of molecules in the compartment connected component + my $compartment_connected = {}; + + # find the compartment connected component using a depth first search (recursive) + &depth_first_search( $i_mol, $adjacency_hash, $compartment_connected ); + return ( keys %$compartment_connected ); + + + sub depth_first_search + # recursive method to find connected component of graph + # vertex: index of the starting vertex. + # adjacency: reference to hash that maps vertices to the set of adjacent vertices. + # connected_component: reference to a hash whose keys are vertices in the connected component. + { + my ( $vertex, $adjacency, $connected_component ) = @_; + + # do nothing if vertex was already found + return if ( exists $connected_component->{$vertex} ); + + # vertex is in connected component + $connected_component->{$vertex} = 1; + + # search edges at this vertex + foreach my $adjacent_vertex ( @{ $adjacency->{$vertex} } ) { + &depth_first_search( $adjacent_vertex, $adjacency, + $connected_component ); + } + } +} + + + + +### +### +### + + + +# Copy a list of graphs and merge into one supergraph. +# SpeciesGraph labels, IDs, and attributes are ignored. +# But Labels for molecules and components are preserved. +# +# Copy merge also builds an offsets array, indicating the +# first molecule associated with the ith connected component +sub copymerge +{ + # get list of species to copy/merge + my @sgs = @_; + + # build offsets array: + # offset[i] = index of first molecule of reactant i in the aggregate graph + my $offsets = [ (0) x @sgs ]; + + # create new speciesgraph to hold copy + my $sg_copy = SpeciesGraph->new(); + + # create array to hold copied molecules + my $mol_copy = []; + $sg_copy->Molecules($mol_copy); + + # loop over subgraphs and copy + my $allow_dangling = FALSE; + my $offset = 0; + for ( my $i_sg = 0; $i_sg < @sgs; ++$i_sg ) + { + my $sg = $sgs[$i_sg]; + + # get offsets + $offsets->[$i_sg] = $offset; + $offset += @{$sg->Molecules}; + + # if we find a non-species graph, then allow dangling! + unless ( defined $sg->Species and ref $sg->Species eq 'SPECIES' ) + { $allow_dangling = TRUE; } + + # copy molecules + foreach my $mol ( @{$sg->Molecules} ) + { + # This form of Molecule->copy adds a prefix to the edges to avoid + # overlap of edge names between different SpeciesGraphs + push @$mol_copy, $mol->copy( 1, "${i_sg}_" ); + } + } # END loop over SpeciesGraphs + + + # update graph edges + my $err = $sg_copy->updateEdges( $allow_dangling ); + if ( $err ) { print "SpeciesGraph::copymerge(): updateEdges failed with error:\n $err\n"; } + + # return copy + return ($sg_copy, $offsets); +} + + + +### +### +### + + + +# Make an exact copy of a SpeciesGraph, including all labels, IDs, etc +# NOTE: associated Species object, if exists, will not be copied (but we'll preserve the reference) +sub copy +{ + # get speciesGraph to copy + my $sg = shift; + # copy labels? + my $copy_labels = @_ ? shift @_ : TRUE; + # should we generate a label if we're not copying one? + my $get_label = @_ ? shift @_ : TRUE; + + # create new speciesgraph to hold copy + my $sg_copy = SpeciesGraph->new(); + + # copy scalar members + $sg_copy->Name( $sg->Name ); + $sg_copy->Compartment( $sg->Compartment ) if (defined $sg->Compartment); + $sg_copy->Quantifier( $sg->Quantifier ); + $sg_copy->MatchOnce( $sg->MatchOnce ); + $sg_copy->Fixed( $sg->Fixed ); + $sg_copy->Automorphisms( $sg->Automorphisms ); + + # copy molecules + if ( @{$sg->Molecules} ) + { + $sg_copy->Molecules( [map {$_->copy($copy_labels)} @{$sg->Molecules}] ); + } + + if ($copy_labels) + { + # copy labels, IDs, etc.. + $sg_copy->Label( $sg->Label ); + $sg_copy->StringID( $sg->StringID ); + $sg_copy->StringExact( $sg->StringExact ); + $sg_copy->IsCanonical( $sg->IsCanonical ); + + # copy edges + foreach my $edge ( @{$sg->Edges} ) + { + if ( ref $edge eq 'ARRAY' ) + { push @{$sg_copy->Edges}, [@$edge]; } + else + { push @{$sg_copy->Edges}, $edge; } + } + # copy adjacency + while ( my ($key,$val) = each %{$sg->Adjacency} ) + { + if ( ref $val eq 'HASH' ) + { %{ $sg_copy->Adjacency->{$key} } = %{$val}; } + else + { $sg_copy->Adjacency->{$key} = $val; } + } + } + else + { + if ($get_label) + { + # generate label and, as side-effect, build Edges and Adjacencies + my $err = $sg_copy->sortLabel( ALLOW_DANGLING_BONDS, TRIM_DANGLING_BONDS ); + if ($err) { print "SpeciesGraph::copy(): sortLabel failed with error:\n $err\n"; } + } + else + { + # Build Edges and Adjacencies, but don't get label + my $err = $sg_copy->updateEdges( ALLOW_DANGLING_BONDS, TRIM_DANGLING_BONDS ); + if ($err) { print "SpeciesGraph::copy(): updateEdges failed with error:\n $err\n"; } + } + } + + if (defined $sg->Species) + { # pass the Species reference to the copy (but don't copy the Species!) + $sg_copy->Species( $sg->Species ); + } + + + # return copy + return $sg_copy; +} + + + +### +### +### + + +# call this method to link Compartments to a new CompartmentList +sub relinkCompartments +{ + my $sg = shift; + my $clist = shift; + + if ( defined $sg->Compartment ) + { + my $new_comp = $clist->lookup( $sg->Compartment->Name ); + $sg->Compartment( $new_comp ); + } + + foreach my $mol ( @{$sg->Molecules} ) + { + $mol->relinkCompartments( $clist ); + } + + return $sg; +} + + + +### +### +### + + + +# gather all labels associated with this Species +sub gatherLabels +{ + my $sg = shift @_; + my $label_map = shift @_; + my $i_sg = (@_) ? shift : 0; + + $label_map->{$sg->Label} = $i_sg if (defined $sg->Label); + for ( my $i_mol = 0; $i_mol < @{$sg->Molecules}; ++$i_mol ) + { + my $mol = $sg->Molecules->[$i_mol]; + $label_map->{$mol->Label} = "$i_sg.$i_mol" if (defined $mol->Label); + + for ( my $i_comp = 0; $i_comp < @{$mol->Components}; ++$i_comp ) + { + my $comp = $mol->Components->[$i_comp]; + $label_map->{$comp->Label} = "$i_sg.$i_mol.$i_comp" if (defined $comp->Label); + } + } +} + + +### +### +### + + +sub isPopulationType +{ + my $sg = shift @_; + my $mtlist = shift @_; + + my $mt = $mtlist->MolTypes->{$sg->Molecules->[0]->Name}; + return (defined $mt->PopulationType) ? $mt->PopulationType : 0; +} + + + +### +### +### + + + +# assign unique labels to molecules and components of this species +sub assignLabels +{ + my $sg = shift @_; + my $start_index = shift @_; + my $new_labels = shift @_; + my $used_labels = shift @_; + + my $base = 'T'; + my $i_label = $start_index; + foreach my $mol ( @{$sg->Molecules} ) + { + unless ( defined $mol->Label ) + { + while ( exists $used_labels->{"$base$i_label"} ) + { ++$i_label; } + $mol->Label( "$base$i_label" ); + $new_labels->{"$base$i_label"} = 1; + ++$i_label; + } + foreach my $comp ( @{$mol->Components} ) + { + unless ( defined $comp->Label ) + { + while ( exists $used_labels->{"$base$i_label"} ) + { ++$i_label; } + $comp->Label( "$base$i_label" ); + $new_labels->{"$base$i_label"} = 1; + ++$i_label; + } + } + } + return $i_label; +} + + + +### +### +### + + + +# search for and remove specific labels +sub removeLabels +{ + my $sg = shift @_; + my $delete_labels = shift @_; + + foreach my $mol ( @{$sg->Molecules} ) + { + if ( defined $mol->Label ) + { + if ( exists $delete_labels->{$mol->Label} ) + { $mol->Label(undef); } + } + foreach my $comp ( @{$mol->Components} ) + { + if ( defined $comp->Label ) + { + if ( exists $delete_labels->{$comp->Label} ) + { $comp->Label(undef); } + } + } + } +} + + + +### +### +### + + +# remove labels that are not required to enforce the correct mapping +# a set of 'reactant' species graphs to 'product' species graphs. +sub removeRedundantLabels +{ + my ($sgs1, $sgs2, $temp_labels) = @_; + + # autolabel molecules + my $autolabels1 = autolabel_molecules($sgs1, $temp_labels); + my $autolabels2 = autolabel_molecules($sgs2, $temp_labels); + + # balance autolabels + foreach my $key ( keys %$autolabels1) + { + unless ( exists $autolabels2->{$key} ) + { $autolabels2->{$key} = []; } + } + foreach my $key ( keys %$autolabels2) + { + unless ( exists $autolabels1->{$key} ) + { $autolabels1->{$key} = []; } + } + + # remove temporary molecule labels that are not required for the correspondence mapping + foreach my $key ( keys %$autolabels1 ) + { + my @set1 = @{$autolabels1->{$key}}; + my @set2 = @{$autolabels2->{$key}}; + + while ( @set1 ) + { # get molecule 1 + my ($ip1,$im1) = split (/\./, shift @set1); + my $mol1 = $sgs1->[$ip1]->Molecules->[$im1]; + + my $found_match = 0; # true if we found a map for obj1 + my $ambiguous = 0; # true if the mapping may be ambiguous + # look for the first object in set2 that matches + my $idx2 = 0; + while ( $idx2 < @set2 ) + { # get molecule 2 + my ($ip2,$im2) = split (/\./, $set2[$idx2]); + my $mol2 = $sgs2->[$ip2]->Molecules->[$im2]; + + if ( defined $mol1->Label and defined $mol2->Label ) + { + if ( $mol1->Label eq $mol2->Label ) + { + if ( not $ambiguous and exists $temp_labels->{$mol1->Label} ) + { # labels are the same and temporary, so we can remove them! + $mol1->Label(undef); $mol2->Label(undef); + } + remove_redundant_component_labels( $mol1, $mol2, $temp_labels ); + splice @set2, $idx2, 1; + $found_match = 1; + } + else + { # labels are different. keep looking for a match + if ( exists $temp_labels->{$mol1->Label} and exists $temp_labels->{$mol2->Label} ) + { # things could get ambiguous since neither label is non-temporary! + $ambiguous = 1; + } + ++$idx2; + } + } + elsif ( not defined $mol1->Label and not defined $mol2->Label ) + { # neither object is labeled. this is a good match + remove_redundant_component_labels( $mol1, $mol2, $temp_labels ); + splice @set2, $idx2, 1; + $found_match = 1; + } + elsif ( defined $mol1->Label ) + { # one label defined, the other not. keep looking for a match + $ambiguous = 1 if ( exists $temp_labels->{$mol1->Label} ); + ++$idx2; + } + elsif ( defined $mol2->Label ) + { # one label defined, the other not. keep looking for a match + $ambiguous = 1 if ( exists $temp_labels->{$mol2->Label} ); + ++$idx2; + } + + last if ($found_match); + } + + unless ($found_match) + { # can't find any good matches for mol1 + $mol1->Label(undef) if ( not $ambiguous and defined $mol1->Label and exists $temp_labels->{$mol1->Label} ); + foreach my $comp ( @{$mol1->Components} ) + { # remove temporary component labels + $comp->Label(undef) if ( defined $comp->Label and exists $temp_labels->{$comp->Label} ); + } + } + } + + # handle product molecules without a match on the reactant side + while (@set2) + { # get molecule 2 + my ($ip2,$im2) = split (/\./, shift @set2); + my $mol2 = $sgs2->[$ip2]->Molecules->[$im2]; + + if ( defined $mol2->Label and exists $temp_labels->{$mol2->Label}) + { # remove temporary label + $mol2->Label(undef); + } + foreach my $comp ( @{$mol2->Components} ) + { # remove temporary component labels + $comp->Label(undef) if ( defined $comp->Label and exists $temp_labels->{$comp->Label} ); + } + } + } + + return; + + + # build autolabels for molecules belonging to species graphs in an array + sub autolabel_molecules + { + my ($sgs, $temp_labels) = @_; + # build auto-labels for reactant molecules + my $autolabels = {}; + for ( my $ip = 0; $ip < @$sgs; ++$ip ) + { + my $patt = $sgs->[$ip]; + for ( my $im = 0 ; $im < @{$patt->Molecules} ; ++$im ) + { + my $mol = $patt->Molecules->[$im]; + my @comps = (); + foreach my $comp ( @{$mol->Components} ) + { + if ( defined $comp->Label and (not exists $temp_labels->{$comp->Label}) ) + { push @comps, "%" . $comp->Label; } + else + { push @comps, $comp->Name; } + } + my $mlabel = ((defined $mol->Label) and (not exists $temp_labels->{$mol->Label})) ? + ("%" . $mol->Label) : $mol->Name; + # add component names so we can distinguish molecules of the same type w/ different listed components. + $mlabel .= '_' . join( '_', sort @comps ) if (@comps); + $autolabels->{$mlabel} = [] unless (exists $autolabels->{$mlabel}); + push @{$autolabels->{$mlabel}}, "$ip.$im"; + } + } + return $autolabels; + } + + # removes redundant component labels + sub remove_redundant_component_labels + { + my ($mol1, $mol2, $temp_labels) = @_; + + my $autolabels1 = autolabel_components($mol1, $temp_labels); + my $autolabels2 = autolabel_components($mol2, $temp_labels); + + # balance autolabels + foreach my $key ( keys %$autolabels1) + { + unless ( exists $autolabels2->{$key} ) + { $autolabels2->{$key} = []; } + } + foreach my $key ( keys %$autolabels2) + { + unless ( exists $autolabels1->{$key} ) + { $autolabels1->{$key} = []; } + } + + # remove temporary molecule labels that are not required for the correspondence mapping + foreach my $key ( keys %$autolabels1 ) + { + my @set1 = @{$autolabels1->{$key}}; + my @set2 = @{$autolabels2->{$key}}; + + while ( @set1 ) + { # get component 1 + my $comp1 = $mol1->Components->[ shift @set1 ]; + + my $found_match = 0; # true if we found a map for obj1 + my $ambiguous = 0; # true if the mapping may be ambiguous + # look for the first object in set2 that matches + my $idx2 = 0; + while ( $idx2 < @set2 ) + { # get component 2 + my $ic2 = $set2[$idx2]; + my $comp2 = $mol2->Components->[$ic2]; + + if ( defined $comp1->Label and defined $comp2->Label ) + { + if ( $comp1->Label eq $comp2->Label ) + { + if ( not $ambiguous and exists $temp_labels->{$comp1->Label} ) + { # labels are the same and temporary, so we can remove them! + $comp1->Label(undef); $comp2->Label(undef); + } + splice @set2, $idx2, 1; + $found_match = 1; + } + else + { # labels are different. keep looking for a match + if ( exists $temp_labels->{$comp1->Label} and exists $temp_labels->{$comp2->Label} ) + { # things could get ambiguous since neither label is non-temporary! + $ambiguous = 1; + } + ++$idx2; + } + } + elsif ( not defined $comp1->Label and not defined $comp2->Label ) + { # neither object is labeled. this is a good match + splice @set2, $idx2, 1; + $found_match = 1; + } + elsif ( defined $comp1->Label ) + { # one label defined, the other not. keep looking for a match + $ambiguous = 1 if ( exists $temp_labels->{$comp1->Label} ); + ++$idx2; + } + elsif ( defined $comp2->Label ) + { # one label defined, the other not. keep looking for a match + $ambiguous = 1 if ( exists $temp_labels->{$comp2->Label} ); + ++$idx2; + } + # did we find a match? + last if ($found_match); + } + + unless ($found_match) + { # can't find any good matches for comp1 + $comp1->Label(undef) if ( not $ambiguous and defined $comp1->Label and exists $temp_labels->{$comp1->Label} ); + } + } + + # handle product molecules without a match on the reactant side + while (@set2) + { # get component 2 + my $ic = shift @set2; + my $comp = $mol2->Components->[$ic]; + if ( defined $comp->Label and exists $temp_labels->{$comp->Label}) + { # remove temporary label + $comp->Label(undef); + } + } + } + } + + # build autolabels for components belonging to a molecule + sub autolabel_components + { + my ($mol, $temp_labels) = @_; + my $autolabels = {}; + for ( my $ic = 0 ; $ic < @{$mol->Components} ; ++$ic ) + { + my $comp = $mol->Components->[$ic]; + my $clabel = ((defined $comp->Label) and (not exists $temp_labels->{$comp->Label})) ? + ("%" . $comp->Label) : $comp->Name; + $autolabels->{$clabel} = [] unless (exists $autolabels->{$clabel}); + push @{$autolabels->{$clabel}}, "$ic"; + } + return $autolabels; + } +} + + +### +### +### + + + + + +sub copySubgraph +# given a speciesGraph $sg with n-connected components, an array @$subgraph +# that maps the ith molecule to the jth graph component, and a +# component index $nsub: Creates a copy of component $nsub and returns +# the corresponding species graph. +# +# NOTE: it is assumed the components have no dangling-edges!! If updateEdges +# fails a warning is printed to the default output. +{ + my ($sg, $subgraph, $nsub) = @_; + + # holds error value + my $err; + + # Create SG to hold subgraph copy + my $sg_copy = SpeciesGraph->new(); + + # copy molecules in the subgraph + my $mol_copy = []; + $sg_copy->Molecules( $mol_copy ); + foreach my $imol ( 0 .. $#{$sg->Molecules} ) + { + next unless ( $$subgraph[$imol] == $nsub ); + push @$mol_copy, $sg->Molecules->[$imol]->copy(); + } + + # update graph edges + $err = $sg_copy->updateEdges( !ALLOW_DANGLING_BONDS ); + if ( $err ) { print "WARNING: $err.\n"; } + + return $sg_copy; +} + + + + + +### +### +### + + + +# returns the number of molecules with name $mname +# in species graph $sg. +sub stoich +{ + my $sg = shift @_; + my $mname = shift @_; + my $count = 0; + + foreach my $mol ( @{ $sg->Molecules } ) + { + next if ( $mname cmp $mol->Name ); + ++$count; + } + return ($count); +} + + + + + +### +### +### + + + +sub updateEdges +# this method matches speciesGraph edges by labels, then sorts them, numbers them, +# and stores the list at @{$sg->Edges}. An adjacency hash is also created +# and stored at @{$sg->Adjacency}. Returns undefined value if edges are ok. Returns +# error message otherwise. +# +# Notes: edge array format = "m1.c1 m2.c2" +# adjacency hash keys = {m1.c1}{m2.c2}, except for dangling edge keys = {m1.c1} +# Molecules and Components should be pre-sorted before calling this routine. +# +# Q: why are edges sorted? For quasi-canonical labeling? + +{ + my $sg = shift @_; + # should updateEdges allow dangling edges? + my $allow_dangling = @_ ? shift @_ : FALSE; + # should updateEdges trim dangling edges? + my $trim_dangling = @_ ? shift @_ : FALSE; + + # holds error value for return + my $err = undef; + + # Loop through molecules and components and create map + # from edge labels to a list of molecule and component pointers: + # i.e. %labeled_edges: elabel -> [m1, c1, m2, c2 ...] + my %labeled_edges = (); + my $i_mol = 0; + foreach my $mol ( @{$sg->Molecules} ) + { + # Loop over components + my $i_comp = 0; + foreach my $comp ( @{$mol->Components} ) + { + my @wildcards = (); + # loop over edge labels at this component + foreach my $elabel ( @{$comp->Edges} ) + { + if ( $elabel =~ /^[+?]$/ ) + { # keep wildcard to put on component edge list + push @wildcards, $elabel; + } + else + { # handle labeled edge + push @{$labeled_edges{$elabel}}, [$i_mol, $i_comp]; + } + } + + # clear out edges! and restore wildcards, if any. + $comp->Edges( [@wildcards] ); + ++$i_comp; + } + ++$i_mol; + } + + + # clear sg edges array + my $edges = []; + $sg->Edges($edges); + + # clear adjacency hash + my $adjacency = {}; + $sg->Adjacency($adjacency); + + # sort edges and reindex from 0 + my $iedge = 0; + my ($p1, $m1, $c1, $p2, $m2, $c2); + foreach my $edge ( sort edge_sort values %labeled_edges ) + { + if ( @$edge == 2 ) + { + # get molecule and component indices + ($m1, $c1) = @{$edge->[0]}; + ($m2, $c2) = @{$edge->[1]}; + # create pointer to bond end2 + $p1 = "$m1.$c1"; + $p2 = "$m2.$c2"; + # update adjacency hash + $adjacency->{$p1}{$p2} = $iedge; + $adjacency->{$p2}{$p1} = $iedge; + # add edge label to components + push @{ $sg->Molecules->[$m1]->Components->[$c1]->Edges }, $iedge; + push @{ $sg->Molecules->[$m2]->Components->[$c2]->Edges }, $iedge; + # add edge definition to edge array + push @$edges, "$p1 $p2"; + ++$iedge; + } + elsif ( @$edge==1 and $allow_dangling ) + { + if ($trim_dangling) + { # trim dangling edge + # don't increment $iedge counter + } + else + { # keep dangling edges, but convert to "+" wildcard + # get molecule and component indices + ($m1, $c1) = @{$edge->[0]}; + push @{$sg->Molecules->[$m1]->Components->[$c1]->Edges}, "+"; + } + } + elsif ( @$edge==1 and !$allow_dangling ) + { $err = "SpeciesGraph::updateEdges(): dangling edge not allowed in species graph!"; } + elsif ( @$edge > 2 ) + { $err = "SpeciesGraph::updateEdges(): edge binds more than 2 components!"; } + else + { $err = "SpeciesGraph::updateEdges(): unknown error!"; } + } + + return $err; +} + + + +### +### +### + + + +sub toString +{ + # get this species graph + my $sg = shift @_; + # get arguments + my $print_edges = @_ ? shift @_ : TRUE; # if true, egde labels are printed + my $print_attributes = @_ ? shift @_ : TRUE; # if true, species attributes are printed (don't use this for Canonical labeling!!) + #special output handling + my $print_options = @_ ? shift @_: (); + # initialize string + my $string = ''; + + # header + # NOTE: printing name messes up use of StringExact for hashing species + if ($print_attributes) + { + if ($sg->Name) + { $string .= $sg->Name; } + + if ($sg->Label) + { $string .= '%' . $sg->Label; } + } + + if ( $sg->Compartment ) + { $string .= '@' . $sg->Compartment->Name; } + + if ($string) + { $string .= "::"; } + + # attributes + if ($print_attributes) + { + # gather attributes + my @attr = (); + if ( $sg->MatchOnce ) + { push @attr, "MatchOnce"; } + + # put additional attributes here! + + # write attributes to string + if (@attr) + { $string .= '{' . join( ',', @attr ) . '}'; } + + # Handle "Fixed" by prepending '$' + if ( $sg->Fixed ) + { $string .= '$'; } + } + + # write the molecules + my $imol = 0; + foreach my $mol ( @{$sg->Molecules} ) + { + if ($imol > 0) { $string .= '.'; } + $string .= $mol->toString( $print_edges, $print_attributes, $sg->Compartment, $print_options ); + ++$imol; + } + + + if ($print_attributes) + { # write quantifier (if any + if ( $sg->Quantifier ) + { $string .= $sg->Quantifier; } + } + + return $string; +} + + + + +### +### +### + + + +sub toStringSSC { + my $sg = shift @_; + my $suppress_edge_names = (@_) ? shift @_ : 0; + + my $string = ''; + my $imol = 0; + + # attributes + if ( $sg->MatchOnce ) + { + print STDOUT"\n WARNING: SSC does not implement MatchOnce. Though this rule has been translated, "; + print STDOUT"\n Please remove any usage of MatchOnce, as otherwise SSC will not compile the rule. "; + print STDOUT"\n See .rxn file for more details. "; + } + + my $checkSameComp; + foreach my $mol ( @{$sg->Molecules} ) + { + if ($imol) { $string .= ''; } + ( my $tempstring, $checkSameComp ) = $mol->toStringSSC(); + $string .= $tempstring; + ++$imol; + } + unless ( $checkSameComp == 0 ) { return ($string, $checkSameComp); } + return ( $string, 0 ); +} + + + +### +### +### + + + +# this toString is just used in corresponding seed species block. +# As in SSC one only specifies molecules, molecules if they hava a defined states +# Or molecules with bonds. +sub toStringSSCMol +{ + my $sg = shift @_; + my $print_edges = (@_) ? shift @_ : TRUE; + + my $string = ''; + my $imol = 0; + foreach my $mol ( @{$sg->Molecules} ) + { + if ($imol) { $string .= ''; } + $string .= $mol->Name; + $string .= $mol->toStringSSCMol( $print_edges ); #Calls toStringSSCMol of Molecule.pm + + ++$imol; + } + return $string; +} + + + +### +### +### + + + +# NOTE: Doesn't return enclosing contained because it is assumed that this is called from specific +# class containing a SpeciesGraph, e.g. Species, or Reactants or Products in RxnRule. + +sub toXML +{ + my $sg = shift @_; + my $indent = shift @_; + my $type = shift @_; + my $id = shift @_; + my $attributes = shift @_; + + my $string = $indent . "<$type"; + + # Attributes + # id + $string .= " id=\"" . $id . "\""; + + # other attributes + unless ( $attributes eq '' ) { $string .= ' ' . $attributes; } + + # Label + if ( $sg->Label ) + { + $string .= " label=\"" . $sg->Label . "\""; + } + + # Compartment + if ( $sg->Compartment ) + { + $string .= " compartment=\"" . $sg->Compartment->Name . "\""; + } + + # add support for MatchOnce keyword + if ( $sg->MatchOnce ) + { + $string .= " matchOnce=\"1\""; + } + + # add support for Fixed + if ( $sg->Fixed ) + { + $string .= " Fixed=\"1\""; + } + + + # add support for Automorphism count (TODO: disabled for now) + #if ( defined $sg->Automorphisms ) + #{ + # $string .= " automorphisms=\"" . $sg->Automorphisms . "\""; + #} + + # add quantifiers + if ( $sg->Quantifier ) + { + my ( $relation, $quantity ) = ( $sg->Quantifier =~ /(=|==|<=|>=|<|>)(\d+)/ ); + $string .= ' relation="' . $relation . '" quantity="' . $quantity . '"'; + } + + # Objects contained + my $indent2 = ' ' . $indent; + my $ostring = ''; + + # Molecules + if ( @{$sg->Molecules} ) + { + $ostring .= $indent2 . "\n"; + my $index = 1; + foreach my $mol ( @{$sg->Molecules} ) + { + $ostring .= $mol->toXML( " " . $indent2, $id, $index ); + ++$index; + } + $ostring .= $indent2 . "\n"; + } + + # Bonds + if ( @{$sg->Edges} ) + { + my $bstring = ''; + my $index = 1; + my $indent3 = ' ' . $indent2; + foreach my $edge ( @{$sg->Edges} ) + { + my ($p1, $p2) = split ' ', $edge; + next unless (defined $p2); # Only print full bonds; half-bonds handled by BindingState variable in Components + my $bid = sprintf "${id}_B%d", $index; + $bstring .= $indent3 . "p_to_label( $p1, $id ) . "\""; + $bstring .= " site2=\"" . $sg->p_to_label( $p2, $id ) . "\""; + $bstring .= "/>\n"; + ++$index; + } + if ($bstring) + { + $ostring .= $indent2 . "\n" + . $bstring + . $indent2 . "\n"; + } + } + + # Termination + if ($ostring) + { + $string .= ">\n"; # terminate tag opening + $string .= $ostring; + $string .= $indent . "\n"; + } + else + { + $string .= "/>\n"; # short tag termination + } + + return $string; +} + + + + +### +### +### + + +sub toSBMLMultiSpecies +{ + + my $sg = shift @_; + my $mtlist = shift @_; + my $indent = shift @_; + my $type = shift @_; + my $id = shift @_; + my $attributes_ref = shift @_; + my $speciesIdHash_ref = shift @_; + + my $string = $indent . "<$type"; + + # Attributes + # id + $string .= " id=\"" . $id . "\""; + + $speciesIdHash_ref->{'Species'}->{$sg->StringExact} = $id; + # other attributes + #unless ( $attributes eq '' ) { $string .= ' ' . $attributes; } + for my $attrkey (keys %{$attributes_ref}){ + $string .= sprintf(' %s="%s"', $attrkey, $attributes_ref->{$attrkey}); + } + + # Compartment + if ( $sg->Compartment ) + { + $string .= " compartment=\"" . $sg->Compartment->Name . "\""; + + } + else + { + $string .= " compartment=\"cell\""; + } + + if($sg->StringExact) + { + $string .= sprintf(" name=\"%s\"", $sg->StringExact); + } + + + # add support for Fixed + if ( $sg->Fixed ) + { + $string .= "boundaryCondition=\"true\" constant=\"true\""; + } + else{ + $string .= ' boundaryCondition="false" constant="false"'; + } + + #multi:speciesType="st_cps_000001" + + # Objects contained + my $indent2 = ' ' . $indent; + my $ostring = ''; + + my %sbmlMultiSpeciesInfo; + + # Molecules + if ( @{$sg->Molecules} ) + { + + + my $index = 1; + # clone the list of references we need for this particular species (since we will be modifying it) + my %multicomponentHash = %{dclone(\%{$speciesIdHash_ref->{'References'}->{${attributes_ref}->{'multi:speciesType'}}})}; + #print $sg->toString() ."\n"; + #print Dumper \%multicomponentHash; + foreach my $mol ( @{$sg->Molecules} ) + { + $mol->getSBMLMultiSpeciesFields($mtlist, " " . $indent2, ${attributes_ref}->{'multi:speciesType'}, sprintf("%s_M%d", $id, $index), + \%sbmlMultiSpeciesInfo, $speciesIdHash_ref, \%multicomponentHash); + ++$index; + } + + + } + + + + + my $outbonds = ""; + my $features = ""; + + + foreach my $ostr (@{$sbmlMultiSpeciesInfo{'outwardbonds'}}){ + $outbonds = $outbonds . $ostr; + } + if(! $outbonds eq ""){ + $ostring = $ostring . $indent2 . "\n"; + $ostring .= $outbonds; + $ostring = $ostring . $indent2 . "\n"; + } + foreach my $ostr (@{$sbmlMultiSpeciesInfo{'speciesFeature'}}){ + $features = $features . $ostr; + } + if (! $features eq ""){ + $ostring = $ostring . $indent2 . "\n"; + $ostring .= $features; + $ostring = $ostring . $indent2 . "\n"; + } + # Termination + if ($ostring) + { + $string .= ">\n"; # terminate tag opening + $string .= $ostring; + $string .= $indent . "\n"; + } + else + { + $string .= "/>\n"; # short tag termination + } + + return $string; +} + +sub toSBMLMultiSpeciesType +{ + my $sg = shift @_; + my $mtlist = shift @_; + my $indent = shift @_; + my $type = shift @_; + my $id = shift @_; + my $attributes = shift @_; + my $sbmlMultiSpeciesInfo_ref = shift @_; + my $speciesIdHash_ref = shift @_; + my $n_mol = scalar( @{ $sg->Molecules } ); + + my $attributes_str = ''; + + for my $attrkey (keys %{$attributes}){ + $attributes_str .= sprintf(' %s="%s"', $attrkey, $attributes->{$attrkey}); + } + + my $string = ''; + my $indent2 = $indent; + + if ($n_mol > 1){ + $string .= sprintf("<%s multi:id=\"ST%s\" %s multi:compartment=\"%s\">\n", $type, $id, $attributes_str, "cell"); #$sg->Compartment->Name); + $indent2 .= " "; + $speciesIdHash_ref->{'SpeciesType'}->{$attributes->{"multi:name"}} = sprintf("ST%s",$id); + } + #else{ + # my $stid = "ST_M" . keys(%$sbmlMultiSpeciesInfo_ref); + # $speciesIdHash_ref->{'SpeciesType'}->{$attributes->{"multi:name"}} = $stid; + #} + + #get species features and species type instances from the molecule type lists + if ($mtlist) + { + + my $tmp = $mtlist->toSBMLMultiSpeciesType($sg, "ST" . $id, $indent2, $sbmlMultiSpeciesInfo_ref, $speciesIdHash_ref); + if ($n_mol > 1){ + $string .= $tmp; + } + } + + my $mcounter = 1; + my $stid = "ST$id"; + my @parentEntry; + + + # TODO: we should only include fully specified full bonds and states. other stuff doesnt need to be here + # technically this is only necessary for symmetric stuff but its easier to just index everything + + if($n_mol > 1){ + $string .= $indent . "\n"; + foreach my $molkey (keys %{$speciesIdHash_ref->{'References'}->{"ST".$id}{'Molecules'}}){ + foreach my $entry (@{$speciesIdHash_ref->{'References'}->{"ST".$id}->{'Molecules'}->{$molkey}}){ + #remove the cmp prefix to get the parent sbml_id. + @parentEntry = split(/_/,$entry); + my $parentEntryStr = join('_',@parentEntry[1..$#parentEntry]); + + $string .= $indent2. sprintf("\n", $entry, $parentEntryStr); + } + + } + + foreach my $compkey (keys %{$speciesIdHash_ref->{'References'}->{"ST".$id}{'Components'}}){ + my $centry = $speciesIdHash_ref->{'References'}->{"ST".$id}{'Components'}{$compkey}{'id'}; + my $parent = $speciesIdHash_ref->{'References'}->{"ST".$id}{'Components'}{$compkey}{'parent'}; + my $multiref = $speciesIdHash_ref->{'References'}->{"ST".$id}{'Components'}{$compkey}{'parentMulti'}; + $string .= $indent2. sprintf("\n", $centry, $multiref, $parent); + } + + my %rreferenceClone = %{dclone(\%{$speciesIdHash_ref->{'References'}->{"ST".$id}->{'reverseReferences'}})}; + + my $mindex =0; + foreach my $molecule (@{$sg->Molecules}){ + my $cindex = 0; + foreach my $component(@{$molecule->Components}){ + my $fullstring = sprintf("%s(%s)", $molecule->Name, $component->Name); + $speciesIdHash_ref->{'References'}->{"ST".$id}->{'bng2multi'}->{"$mindex.$cindex"} = $rreferenceClone{$fullstring}[0]; + splice(@{$rreferenceClone{$fullstring}}, 0, 1); + + #push @{$edgeHash{$edge}}, (sprintf "ST%d_M%d_C%d", $id, $mindex+1, $cindex+1); + $cindex += 1; + } + # discard molecule references we no longer need + foreach my $key (%rreferenceClone){ + while(defined($rreferenceClone{$key}) and @{$rreferenceClone{$key}} and index(@{$rreferenceClone{$key}}[0], sprintf("M%d", $mindex + 1)) >= 0) { + splice(@{$rreferenceClone{$key}},0,1); + } + } + $mindex += 1; + } + $string .= $indent . "\n"; + #print $sg->toString()."\n"; + #print $sg->StringExact."\n"; + #print Dumper $sg->Edges; + #print Dumper $speciesIdHash_ref->{'References'}->{"ST".$id}->{'bng2multi'}; + if ( @{$sg->Edges} ) + { + + my $bstring = ''; + my $index = 1; + my $indent3 = ' ' . $indent2; + + my $bid1 = ''; + my $bid2 = ''; + + foreach my $edge ( @{$sg->Edges} ) + { + my ($p1, $p2) = split ' ', $edge; + next unless (defined $p2); # Only print full bonds; half-bonds handled by BindingState variable in Components + $bid1 = "cmp_". $speciesIdHash_ref->{'References'}->{"ST".$id}->{'bng2multi'}->{$p1}; + $bid2 = "cmp_" . $speciesIdHash_ref->{'References'}->{"ST".$id}->{'bng2multi'}->{$p2}; + + my $a_bid1 = substr($bid1,4); + my $a_bid2 = substr($bid2,4); + foreach my $mol2 (keys %{$speciesIdHash_ref->{'References'}->{"ST" . $id}->{'reverseReferences'}}){ + #if this is a state reference dont do anything + if(substr($mol2,-1) eq "~"){ + next; + } + #remove components that can't possibly be outward bonds (because they are inward bonds) from the list of reverseReferences + my $index2 = first_index {$_ eq $a_bid1 } @{$speciesIdHash_ref->{'References'}->{"ST" . $id}->{'reverseReferences'}->{$mol2}}; + if ($index2 >=0){ + splice(@{$speciesIdHash_ref->{'References'}->{"ST" . $id}->{'reverseReferences'}->{$mol2}}, $index2, 1); + } + + $index2 = first_index {$_ eq $a_bid2 } @{$speciesIdHash_ref->{'References'}->{"ST" . $id}->{'reverseReferences'}->{$mol2}}; + if ($index2 >= 0){ + splice(@{$speciesIdHash_ref->{'References'}->{"ST" . $id}->{'reverseReferences'}->{$mol2}}, $index2, 1); + } + + + #; + } + + + $bstring .= sprintf("%s\n", $indent3, $bid1, $bid2); + + ++$index; + } + if ($bstring) + { + $string .= $indent2 . "\n" + . $bstring + . $indent2 . "\n"; + } + } + + $string .= sprintf("%s\n", $indent, $type); + } + + return $string; + + +} + + +### +### +### + + +sub addEdge +{ + my $sg = shift @_; + my $ename = shift @_; + + foreach my $pmc (@_) + { + my ( $im, $ic ) = split( '\.', $pmc ); + push @{ $sg->Molecules->[$im]->Components->[$ic]->Edges }, $ename; + } + + return $sg; +} + + + + +### +### +### + + + +sub deleteEdge +{ + my ($sg, $p1, $p2) = @_; + + return unless exists $sg->Adjacency->{$p1}{$p2}; + my $ename = $sg->Adjacency->{$p1}{$p2}; + + my $ndrop = 0; + foreach my $p ( $p1, $p2 ) + { + my ($im, $ic) = split '\.', $p; + my $cedges = $sg->Molecules->[$im]->Components->[$ic]->Edges; + foreach my $ie (0 .. $#$cedges) + { + if ( $cedges->[$ie] eq $ename ) + { + splice @$cedges, $ie, 1; + ++$ndrop; + last; + } + } + } + + unless ( $ndrop == 2 ) + { + exit_error("deleteEdge acted $ndrop times instead of the correct 2"); + } + + return $sg; +} + + + +### +### +### + + + +# NOTE: the original findConnected was removed +# and replaces with findConnected2. --Justin, 25mar2011 + +# Modified version that returns n_subgraphs +# and single array containing index of subgraph +# to which molecule with each index corresponds +sub findConnected +{ + my $sg = shift @_; + + my @subgraph = (0) x @{$sg->Molecules}; + my $n_subgraph = 0; + while (1) + { + # Find first molecule that hasn't been included in a subgraph + my $imol_start = -1; + foreach my $imol ( 0 .. $#subgraph ) + { + if ( $subgraph[$imol] == 0 ) + { + $imol_start = $imol; + last; + } + } + last if ( $imol_start < 0 ); + ++$n_subgraph; + + # Start search from first unreached molecule + $subgraph[$imol_start] = $n_subgraph; + my @mol_new = ($imol_start); + while (@mol_new) + { + my @mol_next = (); + + # Loop over molecules in mol_new + foreach my $imol (@mol_new) + { + my $mol = $sg->Molecules->[$imol]; + + # Loop over components in molecule + for ( my $icomp=0; $icomp < @{$mol->Components}; ++$icomp ) + { + my $p = "$imol.$icomp"; + + # Loop over edges from component + foreach my $q ( keys %{$sg->Adjacency->{$p}} ) + { + my ($im, $ic) = split '\.', $q; + if ( $subgraph[$im] == 0 ) + { + $subgraph[$im] = $n_subgraph; + push @mol_next, $im; + } + } + } + } + @mol_new = @mol_next; + } + } + return ($n_subgraph, [@subgraph]); +} + + + +### +### +### + + + +# check the graph is connected! +sub isConnected +{ + my $sg = shift; + + # find the connected component + my $connected_component = {}; + $sg->depthFirstMoleculeSearch( 0, $connected_component ); + + for ( my $imol = 0; $imol < @{$sg->Molecules}; ++$imol ) + { + return 0 unless ( exists $connected_component->{$imol} ); + } + + return 1; +} + + +### +### +### + + +# Split graph into connected components. +# Pass an optional array reference to forces molecule i into component map[i]. +# (Returns an error if forced mapping introduces a complex). +# NOTE: this method does create canonical labels. +sub splitConnectedComponents +{ + my $sg = shift @_; + # force a subset of molecules to map to specific patterns + my $map_imol_to_ipatt = (@_) ? shift @_ : undef; + + # Do some error checking + my $n_patt; + if ( defined $map_imol_to_ipatt ) + { + unless ( @$map_imol_to_ipatt == @{$sg->Molecules} ) + { # error if map size isn't equal to number of molecules + return "SpeciesGraph->splitConnectedComponents: ERROR! map size is not equal to number of molecules", []; + } + my $max_ipatt = -1; + foreach my $ipatt ( @$map_imol_to_ipatt ) + { + next unless (defined $ipatt); + if ($ipatt > $max_ipatt) { $max_ipatt = $ipatt; } + } + $n_patt = ($max_ipatt == -1) ? 0 : $max_ipatt + 1; + } + else + { # no map specified, create an undefined map + $map_imol_to_ipatt = [(undef) x @{$sg->Molecules}]; + $n_patt = 0; + } + + # initialize vector of species graphs (speed optimization) + my $sgs = [ (undef) x $n_patt ]; + + + # Find all connected components: + # Loop over molecules and do a breadth first search for connected molecules + my $visited = {}; + for ( my $imol = 0; $imol < @{$sg->Molecules}; ++$imol ) + { + # skip molecule if already visited + next if ( exists $visited->{$imol} ); + + # find the connected component + my $connected_component = []; + $sg->breadthFirstMoleculeSearch( $imol, $connected_component, $visited ); + + # loop over connected component and see if any of them have + # a pre-assigned pattern index + my $ipatt = undef; + foreach my $imol2 ( @$connected_component ) + { + if ( defined $ipatt and defined $map_imol_to_ipatt->[$imol2] ) + { # make sure there's no conflict + if ( $ipatt != $map_imol_to_ipatt->[$imol2] ) + { + return "SpeciesGraph->splitConnectedComponents: ERROR!! Connected molecules mapped to different patterns ", []; + } + } + elsif ( defined $map_imol_to_ipatt->[$imol2] ) + { + $ipatt = $map_imol_to_ipatt->[$imol2]; + } + } + + # if ipatt isn't defined, get the next index available + unless ( defined $ipatt ) + { + $ipatt = $n_patt; + ++$n_patt; + } + + # create speciesGraph, if not already created + unless ( defined $sgs->[$ipatt] ) { $sgs->[$ipatt] = SpeciesGraph::new(); } + + # add molecules to the SpeciesGraph + foreach my $imol2 ( sort {$a<=>$b} @$connected_component ) + { + # map imol to ipatt + $map_imol_to_ipatt->[$imol2] = $ipatt; + # add imol to species graph + push @{$sgs->[$ipatt]->Molecules}, $sg->Molecules->[$imol2]; + } + # Don't finalize SpeciesGraph! We might add more molecules later! + } + + # tell original SpeciesGraph to forget about its molecules + # (just to make sure no one tampers with them) + @{$sg->Molecules} = (); + + # make sure all the products are defined + # then build adjacency hash and edge array + my $ipatt = 0; + foreach my $sg2 ( @$sgs ) + { + unless (defined $sg2) + { + return "SpeciesGraph->splitConnectedComponents: ERROR!! No molecules corresponding to SpeciesGraph $ipatt", []; + } + + # Put SpeciesGraph in canonical order + my $err = $sg2->updateEdges(); + if ($err) + { + return "SpeciesGraph->splitConnectedComponents: ERROR!! some problem in updateEdges:\n" . $sg2->toString() . "\n", []; + } + ++$ipatt; + } + + # return + return undef, $sgs; +} + + + +### +### +### + + + +# search through a complex for molecules that satify a condition +sub breadthFirstMoleculeSearch +{ + my $sg = shift; # this SpeciesGraph + my $root_mol = shift; # index of molecule we're starting at + my $found = (@_) ? shift : []; # array of molecules found that satisfy our condition + my $visited = (@_) ? shift : {}; # hashmap of molecules that we've visited + # by default, collect every molecule we encounter + my $condition = (@_) ? shift : sub { return 1; }; + + # initialize a molecule queue + my @mol_queue = ($root_mol); + + # process until until empty + while ( @mol_queue ) + { + # get next molecule on the queue + my $imol = shift @mol_queue; + # skip molecule if already visited + next if ( exists $visited->{$imol} ); + # remember that we visited this molecule + $visited->{$imol} = 1; + + # does this molecule satisfy the condition? + push @$found, $imol if ($condition->($imol)); + + # search through components and look at adjacent molecules + my $mol = $sg->Molecules->[$imol]; + for ( my $icomp = 0; $icomp < @{$mol->Components}; ++$icomp ) + { + my $ptr = "$imol.$icomp"; + foreach my $ptr2 ( keys %{$sg->Adjacency->{$ptr}} ) + { + my ($imol2,$icomp2) = split /\./, $ptr2; + push @mol_queue, $imol2; + } + } + } +} + + + +### +### +### + + + +# search through a complex for molecules that satify a condition +sub depthFirstMoleculeSearch +{ + my $sg = shift; # this SpeciesGraph + my $imol = shift; # index of molecule we're looking at + my $found = (@_) ? shift : {}; # hashmap of molecules found that satisfy our condition + my $visited = (@_) ? shift : {}; # hashmap of molecules we've already visited + # by default, collect every molecule we encounter + my $condition = (@_) ? shift : sub { return 1; }; + + # don't visit a molecule twice + return if ( exists $visited->{$imol} ); + $visited->{$imol} = 1; + + # add this molecule to 'found' if it satifies 'condition' + $found->{$imol} = 1 if ( $condition->($imol) ); + + # search through components and look at adjacent molecules + my $mol = $sg->Molecules->[$imol]; + for ( my $icomp = 0; $icomp < @{$mol->Components}; ++$icomp ) + { + my $ptr = "$imol.$icomp"; + foreach my $ptr2 ( keys %{$sg->Adjacency->{$ptr}} ) + { + my ($imol2,$icomp2) = split /\./, $ptr2; + $sg->depthFirstMoleculeSearch( $imol2, $found, $visited, $condition ); + } + } +} + + + +### +### +### + + + +# Determine if SpeciesGraph is isomorphic to another SpeciesGraph +# Assume that molecules have already been sorted by molecule name and component state +# using cmp_molecule and cmp_component and cmp_edge +# +# TODO: make sure isomorphicTo works correctly on patterns! +sub isomorphicTo +{ + my ($sg1, $sg2) = @_; + + # inequality of StringIDs is sufficient for rejecting isomorphism! + if ( defined $sg1->StringID + and defined $sg2->StringID + and ($sg1->StringID cmp $sg2->StringID) ) + { + #print "[not isomorphic] failed string test: ", $sg1->StringID, " vs ", $sg2->StringID, "\n"; + return 0; + } + + # equality of StringExacts is sufficient for accepting isomorphism! + if ( defined $sg1->StringExact + and defined $sg2->StringExact + and !($sg1->StringExact cmp $sg2->StringExact) ) + { + #print "[isomorphic] passed exact match: ", $sg1->StringExact, " vs ", $sg2->StringExact, "\n"; + return 1; + } + + # quick check: do the speciesGraphs have the same number of molecules? + unless (@{$sg1->Molecules} == @{$sg2->Molecules}) + { return 0; } + + # Nested depth first search, first molecules, then components to find match + my $molecules1 = $sg1->Molecules; + my $molecules2 = $sg2->Molecules; + my $nmol = $#$molecules1; + + my @maps = (); + my @mused = (0) x @$molecules1; + my @mptr = (0) x @$molecules1; + my @cptrs = (); + my @cuseds = (); + + my $im1 = 0; + my ($im2, $ic1, $ic2); + + my $components1 = $molecules1->[$im1]->Components; + my $components2; + my $ncomp = $#$components1; + + my $adj1 = $sg1->Adjacency; + my $adj2 = $sg2->Adjacency; + + # depth first search over Molecules + MITER: + while (1) + { + # find a match at the current level + # Currently loop is done over all possible molecules, but this could be + # changed to loop over molecules adjacent to molecules higher level to + # limit search. + my $mmatch = 0; + + for ( $im2 = $mptr[$im1]; $im2 <= $nmol; ++$im2 ) + { + next if $mused[$im2]; # Continue if this molecule already mapped + next if ( $molecules1->[$im1]->Name cmp $molecules2->[$im2]->Name ); + if ( defined $molecules1->[$im1]->Compartment ) + { # compartment defined for mol1, now compare to mol2 + next unless ( defined $molecules2->[$im2]->Compartment ); + next unless ( $molecules1->[$im1]->Compartment == $molecules2->[$im2]->Compartment ); + } + elsif ( defined $molecules2->[$im2]->Compartment ) + { # compartment defined for mol2, but not mol1 + next; + } + + # skip if different number of components (this can happen when comparing patterns) + next unless ( @{$molecules1->[$im1]->Components} == @{$molecules2->[$im2]->Components} ); + + # Initialize data for component match at this level + $mptr[$im1] = $im2; + $components2 = $molecules2->[$im2]->Components; + $cptrs[$im1] = [ (0) x @$components1 ]; + $cuseds[$im1] = [ (0) x @$components2 ]; + $ic1 = 0; + $mmatch = 1; + last; + } + + # Move up a level (to last component of molecule at previous level) + # if no match molecules found + if ( $mmatch == 0 ) + { + last MITER if ( $im1 == 0 ); + + # Reset molecule pointer at current level + $mptr[$im1] = 0; + --$im1; + $components1 = $molecules1->[$im1]->Components; + $ncomp = $#$components1; + $ic1 = $ncomp; + $im2 = $mptr[$im1]; + ++$cptrs[$im1][$ic1]; + $mused[ $mptr[$im1] ] = 0; + $components2 = $molecules2->[$im2]->Components; + } + + # The CITER loop tries to access undefined values if there are 0 components.. + # in which case we can just skip CITER. + + unless ( @{$molecules1->[$im1]->Components} == 0 ) + { + # Do depth first search over components of molecule 2 + my $cptr = $cptrs[$im1]; + my $cused = $cuseds[$im1]; + CITER: + while (1) + { + my $cmatch = 0; + + for ( $ic2 = $cptr->[$ic1]; $ic2 <= $ncomp; ++$ic2 ) + { + next if $cused->[$ic2]; + if ( $components1->[$ic1]->compare_local( $components2->[$ic2] ) ) + { next; } + + #Check component edges + my $ematch = 1; + my $p1 = "$im1.$ic1"; + my $p2 = "$im2.$ic2"; + EDGE: + foreach my $q1 ( keys %{$adj1->{$p1}} ) + { + my ($jm1, $jc1) = split '\.', $q1; + next if ( $jm1 > $im1 ); + if ( $jm1 == $im1 ) + { + next if ( $jc1 >= $ic1 ); + # exit_error("isomorphicTo can't handle bonds among components of same molecule"); + } + my $q2 = "$mptr[$jm1].$cptrs[$jm1][$jc1]"; + unless ( defined $adj2->{$p2}{$q2} ) + { + $ematch = 0; + last EDGE; + } + } + next unless ($ematch); + + $cptr->[$ic1] = $ic2; + + # Complete mapping of this molecule if $ic1==$ncomp + if ( $ic1 == $ncomp ) + { + $cmatch = 1; + last; + } + else + { + # descend to next component + $cused->[$ic2] = 1; + ++$ic1; + # print "ic1=$ic1 cptr=$cptr[$ic1] ncomp=$ncomp\n"; + next CITER; + } + } + + # Move up a component level if no match found + if ( $cmatch == 0 ) + { + # Move to next molecule at current level if up exhausted + # component search + if ( $ic1 == 0 ) + { + # Increment molecule pointer at current level + ++$mptr[$im1]; + next MITER; + } + + # Reset component pointer at current level + $cptr->[$ic1] = 0; + --$ic1; + $cused->[ $cptr->[$ic1] ] = 0; # Reset pointers at new level + ++$cptr->[$ic1]; + + # print "set ic1 to $ic1 cptr is $cptr[$ic1]\n"; + next CITER; + } + last CITER; + } + } + + # If $im1==$nmol, then graphs are isomorhpic and we can return + if ( $im1 == $nmol ) { return 1; } + + # Move down a level in molecules (increment $im1) + $mused[$im2] = 1; + ++$im1; + $components1 = $molecules1->[$im1]->Components; + $ncomp = $#$components1; + } + + return 0; +} + + + +### +### +### + + + +# Determine if SpeciesGraph is isomorphic +# to a portion of another SpeciesGraph +sub isomorphicToSubgraph +{ + + my $sg1 = shift @_; + my $sg2 = shift @_; + my $root_src = @_ ? shift @_ : -1; + my $root_targ = @_ ? shift @_ : -1; + + #printf STDOUT "SpeciesGraph::isomorphicToSubGraph(sg1=%s,sg2=%s,root_src=%d,root_targ=%d)\n", + # $sg1->toString(), $sg2->toString(), $root_src, $root_targ; + + my $molecules1 = $sg1->Molecules; + my $edges1 = $sg1->Edges; + my $adj1 = $sg1->Adjacency; + + my $molecules2 = $sg2->Molecules; + my $edges2 = $sg2->Edges; + my $adj2 = $sg2->Adjacency; + + my @maps = (); + + # First do some quick checks to see if it's possible to find a subgraph isomorphism + # 1) compare number of molecules + if ( @$molecules1 > @$molecules2 ) { return @maps; } + + # 2) compare number of edges + if ( @$edges1 > @$edges2 ) { return @maps; } + + # 3) compare species compartment + if ( defined $sg1->Compartment ) + { + return @maps unless ( defined $sg2->Compartment ); + return @maps unless ( $sg1->Compartment == $sg2->Compartment ); + } + + # if this is the null graph, then return a trivial subgraph isomorphism + if ( $sg1->isNull() ) + { + my $map = Map->new( Source=>$sg1, Target=>$sg2 ); + push @maps, $map; + return @maps; + } + + ## Now look for a non-trivial subgraph isomorphism + # Nested depth first search, first molecules, then components to find match + + + # the last index for molecules in sg1 and sg2 + my $mol1_last = $#$molecules1; + my $mol2_last = $#$molecules2; + + my @mol1_begin = (0) x @$molecules1; # first index of mol2 that mol1 can match + my @mol1_ptr = (0) x @$molecules1; # current index of mol2 that mol1 is trying to match + my @mol1_end = (scalar @$molecules2) x @$molecules1; # end index of mol2 that mol1 can match + my @mol2_used = (0) x @$molecules2; + + + if ($root_src >= @$molecules1 or $root_targ >= @$molecules2) + { die "SpeciesGraph::isomorphicToSubgraph(): root_src or root_targ is out of range"; } + + if ( ($root_src == -1 and $root_targ >= 0) or ($root_src >= 0 and $root_targ==-1)) + { die "SpeciesGraph::isomorphicToSubgraph(): incompatible root_src and root_targ"; } + + # force molecule $root_src of sg1 to match molecule $root_targ of sg2 + if ($root_src >= 0 and $root_targ >= 0) + { + $mol1_begin[$root_src] = $root_targ; + $mol1_ptr[$root_src] = $root_targ; + $mol1_end[$root_src] = $root_targ + 1; + $mol2_used[$root_targ] = 1; + } + + + my @comp1_ptrs = (undef) x @$molecules1; + my @comp2_useds = (undef) x @$molecules2; + + my $im1 = 0; + my $im2; + + my $components1 = $molecules1->[$im1]->Components; + my $components2; + + my $comp1_last = $#$components1; + my $comp2_last; + + my ($ic1, $ic2); + + # depth first search over Molecules + MITER: + while (1) + { + # find a match at the current level + # Currently loop is done over all possible molecules, but this could be + # changed to loop over molecules adjacent to molecules higher level to limit search. + my $found_mol_match = 0; + for ( $im2 = $mol1_ptr[$im1]; $im2 < $mol1_end[$im1]; ++$im2 ) + { + # Continue if this molecule already mapped + unless ($im1==$root_src) { next if $mol2_used[$im2]; } + + # Is mol2? a candidate match for mol1? + # compare molecule types + next unless ( $molecules1->[$im1]->Name eq $molecules2->[$im2]->Name ); + # compare number of components + next if ( @$components1 > @{$molecules2->[$im2]->Components} ); + # compare compartments + if ( defined $molecules1->[$im1]->Compartment ) + { + next unless ( defined $molecules2->[$im2]->Compartment ); + next unless ( $molecules1->[$im1]->Compartment == $molecules2->[$im2]->Compartment ); + } + + # Initialize data for component match at this level + $mol1_ptr[$im1] = $im2; + $components2 = $molecules2->[$im2]->Components; + $comp1_ptrs[$im1] = [ (0) x @$components1 ]; + $comp2_useds[$im1] = [ (0) x @$components2 ]; + $ic1 = ($comp1_last >= 0) ? 0 : -1; + $found_mol_match = 1; + last; + } + + # if no match found to this molecule, move back to previous molecule and try again + unless ($found_mol_match) + { + last MITER if ( $im1==0 ); + + # Reset molecule pointer at current level + $mol1_ptr[$im1] = $mol1_begin[$im1]; + + # go back to previous molecule + --$im1; + $components1 = $molecules1->[$im1]->Components; + $comp1_last = $#$components1; + $ic1 = $comp1_last; + $im2 = $mol1_ptr[$im1]; + unless ($im1==$root_src) + { $mol2_used[ $mol1_ptr[$im1] ] = 0; } + + if ( $ic1 >= 0 ) + { + ++$comp1_ptrs[$im1][$ic1]; + } + else + { + ++$mol1_ptr[$im1]; + next MITER; + } + $components2 = $molecules2->[$im2]->Components; + } + + # Do depth first search over components of molecule 2 + my $comp1_ptr = $comp1_ptrs[$im1]; + my $comp2_used = $comp2_useds[$im1]; + CITER: + while (1) + { + my $found_comp_match = 0; + if ( $comp1_last >= 0 ) + { + my ($ci1, $ci2); + $ci1 = $components1->[$ic1]; + $comp2_last = $#$components2; + for ( $ic2 = $comp1_ptr->[$ic1]; $ic2 <= $comp2_last; ++$ic2 ) + { + next if $comp2_used->[$ic2]; + $ci2 = $components2->[$ic2]; + + # Component name + next unless ( $ci1->Name eq $ci2->Name ); + # Component state only if present in sg1 + if ( defined $ci1->State ) + { + next unless ( defined $ci2->State); + unless ( $ci1->State eq "?" ) + { next unless ( $ci1->State eq $ci2->State ); } + } + # compare compartments + if ( defined $ci1->Compartment ) + { + next unless ( defined $ci2->Compartment ); + next unless ( $ci1->Compartment eq $ci2->Compartment ); + } + + # Number of component edges must match (primarily used to look for free + # binding sites + # Number of edges + my $diff = @{$ci2->Edges} - @{$ci1->Edges}; + if ($diff) + { + # Mismatch unless first Edge is wildcard + if ( @{$ci1->Edges} ) + { + my $wild = $ci1->Edges->[0]; + next unless ( $wild =~ /^[+?]$/ ); + + # + wildcard requires $diff>=0 (= case handled above) + if ( $wild eq '+' ) + { next unless ( $diff > 0 ); } + else + { # *? (equivalent) wildcard requires $diff>-1, #c2 edges >= #c1 edges - 1 (for wildcard) + next unless ( $diff >= -1 ); + } + } + else + { next; } + } + + #Check component edges + my $ematch = 1; + my $p1 = "$im1.$ic1"; + my $p2 = "$im2.$ic2"; + if (ref $adj1->{$p1} eq 'HASH') + { + EDGE: + foreach my $q1 ( keys %{$adj1->{$p1}} ) + { + my ($jm1, $jc1) = split /\./, $q1; + next if ( $jm1 > $im1 ); + if ( $jm1 == $im1 ) + { + next if ( $jc1 >= $ic1 ); + } + my $q2 = "$mol1_ptr[$jm1].$comp1_ptrs[$jm1][$jc1]"; + unless ( (ref $adj2->{$p2} eq 'HASH') and (exists $adj2->{$p2}{$q2}) ) + { + $ematch = 0; + last EDGE; + } + } + } + next unless ($ematch); + + $comp1_ptr->[$ic1] = $ic2; + + # Complete mapping of this molecule if $ic1==$comp1_last + if ( $ic1 == $comp1_last ) + { + $found_comp_match = 1; + last; + } + else + { # move to next component + $comp2_used->[$ic2] = 1; + ++$ic1; + next CITER; + } + } + } + else + { # No components in pattern + $found_comp_match = 1; + } + + # Move back to previous component if no match found + unless ( $found_comp_match ) + { # Move to next molecule at current level if up exhausted + # component search + if ( $ic1 <= 0 ) + { + # Increment molecule pointer at current level + ++$mol1_ptr[$im1]; + next MITER; + } + + # Reset component pointer at current level + $comp1_ptr->[$ic1] = 0; + --$ic1; + $comp2_used->[ $comp1_ptr->[$ic1] ] = 0; # Reset pointers at new level + ++($comp1_ptr->[$ic1]); + next CITER; + } + + # If $im1==$mol1_last, then graphs are isomorphic and we can return + # Modify to save map for subgraph isomorphism case + if ( $im1 == $mol1_last ) + { + my $map = Map->new; + $map->Source($sg1); + $map->Target($sg2); + my $mapf = {}; + foreach my $im (0 .. $mol1_last) + { + my $im2 = $mol1_ptr[$im]; + $mapf->{$im} = $im2; + my $comp1_ptr = $comp1_ptrs[$im]; + + foreach my $ic ( 0 .. $#$comp1_ptr ) + { $mapf->{"$im.$ic"} = sprintf "%d.%d", $im2, $comp1_ptr->[$ic]; } + } + $map->MapF($mapf); + #print STDOUT " map=", join( ", ", map {"$_->$mapf{$_}"} keys %mapf ), "\n"; + push @maps, $map; + + if ($sg1->MatchOnce) + { last MITER; } + + if ( $comp1_last >= 0 ) + { + ++($comp1_ptr->[$ic1]); + next CITER; + } + else + { # Go to next molecule if no components in the current molecule + ++$mol1_ptr[$im1]; + next MITER; + } + } + last CITER; + } + + # Move to the next molecule in $sg1 + $mol2_used[$im2] = 1; + ++$im1; + $components1 = $molecules1->[$im1]->Components; + $comp1_last = $#$components1; + } + + return @maps; +} + + + +### +### +### + + + +sub getIdentityMap +{ + # get input arguments + my $sg = shift; + + # initialize map hashes + my $mapF = {}; + my $mapR = {}; + + # create map object + my $map = Map::new(); + $map->Source($sg); + $map->Target($sg); + $map->MapF( $mapF ); + $map->MapR( $mapR ); + + # build identity maps + my $im = 0; + foreach my $mol ( @{$sg->Molecules} ) + { + $mapF->{$im} = $im; + $mapR->{$im} = $im; + + my $ic = 0; + foreach my $comp ( @{$mol->Components} ) + { + my $ptr = "$im.$ic"; + $mapF->{$ptr} = $ptr; + $mapR->{$ptr} = $ptr; + ++$ic; + } + ++$im; + } + + return $map; +} + + +### +### +### + + + +sub findMaps + +# (Map) = SpeciesGraph1->findMaps(SpeciesGraph2) +# +# NOTE: This method was originally called "findMaps2". Since findMaps was +# deprecated, it was removed from the code base and findMaps2 was promoted to +# findMaps! +# +# A simplified replacement for findMaps. Finds mapping by first labeling the +# molecules and components and building a map from object labels to the object index +# w.r.t. the species graph. By matching labels in two species graphs, +# the forward and/or reverse map can be generated (map from pointer index to pointer index). +# +# should this be in Map module? +# REVISED by justinshogg@gmail.com 19feb2009 +# TODO: findMaps respects molecule and component tags, but does not attempt to reconile Pattern tags. +{ + # get species graphs + my $sg1 = shift @_; + my $sg2 = shift @_; + + # for each speciesGraph, build a map from object labels to object indices + my $labelmap1 = $sg1->buildLabelMap(); + my $labelmap2 = $sg2->buildLabelMap(); + + # create and setup a new Map object + my $map = Map->new; + $map->Source($sg1); + $map->Target($sg2); + $map->MapF( buildPointerMap( $labelmap1, $labelmap2 ) ); + $map->MapR( buildPointerMap( $labelmap2, $labelmap1 ) ); + + # all done, return map (in a list, for deprecated reasons) + return $map; + + + sub buildPointerMap + # pointermap = buildPointerMap( labelmap1, labelmap2 ); + # DESCR: given 2 label maps, returns a map from label indices in $lmap1 + # to label indices in $lmap2. + # NOTES: the pointer map is a hash (not a Map object) + { + my ( $lmap1, $lmap2 ) = @_; + my $pmap = {}; + foreach my $label ( keys %$lmap1 ) + { # map label index1 to label index2, or -1 if index2 is not defined + $pmap->{ $lmap1->{$label} } = + ( exists $lmap2->{$label} ) ? $lmap2->{$label} : -1; + } + return $pmap; + } +} + + + +### +### +### + + +# What Happened to findMaps2?? +# In revision 354 (distribution 2.1.8+), the original and deprecated findMaps was eliminated from +# the code and findMaps2 was promoted to findMaps! For the old code, see the +# repository or any distribution prior to 2.1.8 --Justin, 16 Dec 2010 + + +### +### +### + + + +sub buildLabelMap + + # labelmap = SpeciesGraph->buildLabelMap() + # this outsources the labeling loop from findMaps + # returns a map from labels to indices +{ + my $sg = shift @_; # species graph + my $labelmap = {}; # initialize map from labels to indices + my %labels = (); # a map of labels (up to replicate index) + # to the number of objects with that label. + + # label molecules + for ( my $im = 0 ; $im < @{$sg->Molecules} ; ++$im ) + { + my $mol = $sg->Molecules->[$im]; # molecule to be labeled + my @clabels = (); # list of component labels + my $mlabel; # molecule label string + + # Get component labels (substitute name, if no label) + foreach my $comp ( @{ $mol->Components } ) + { + if ( defined $comp->Label ) + { push @clabels, '%' . $comp->Label; } + else + { push @clabels, $comp->Name; } + } + + # User provided label supercedes other labeling + # It must be unique for each molecule and each component + if ( defined $mol->Label ) + { + $mlabel = '%' . $mol->Label; + } + else + { # Automatic mol label starts with molname + $mlabel = $mol->Name; + $mlabel .= '_' . join( '_', sort @clabels ) . '_'; + $mlabel .= ++$labels{$mlabel}; + } + + # write map: molecule label -> molecule index + $labelmap->{$mlabel} = $im; + + # Component labels have syntax mlabel|clabel. If user label is + # provided, it has precedence and mlabel is omitted. Otherwise, $clabel + # is name of component plus a number that indicates its order in + # occurence of identical components + for ( my $ic = 0 ; $ic < @clabels ; $ic++ ) + { + # NEW CODE. TODO: Figure this out! + # the old code leaves out user tags, which seems sketchy. + # but adding the tags breaks the state inheritance mechanism. + #my $clabel = $clabels[$ic]; + ## prefix component label with molecule label to ensure that + ## molecule and component maps are compatible + #$clabel = $mlabel . '|' . $clabel . '_'; + #$clabel .= ++$labels{$clabel}; + #$labelmap->{$clabel} = "$im.$ic"; + + # OLD CODE: + my $clabel = $clabels[$ic]; + unless ( $clabel =~ /^\%/ ) + { + # Automatic label + $clabel = $mlabel . '|' . $clabel . '_'; + $clabel .= ++$labels{$clabel}; + } + $labelmap->{$clabel} = "$im.$ic"; + } + } + + return $labelmap; +} + + + +### +### +### + + + +# Canonical order for molecules +sub cmp_molecule +{ + my $a = shift; + my $b = shift; + + my $cmp; + # compare molecule names + if ( $cmp = ( $a->Name cmp $b->Name ) ) + { return $cmp; } + + # compare number of components + if ( $cmp = (@{$a->Components} <=> @{$b->Components}) ) + { return $cmp; } + + # compare by compartment names + if ( defined $a->Compartment ) + { + unless ( defined $b->Compartment ) { return 1 }; + if ( $cmp = ($a->Compartment->Name cmp $b->Compartment->Name) ) + { return $cmp; } + } + elsif ( defined $b->Compartment ) + { + return -1; + } + + # compare by components + for ( my $ic = 0; $ic < @{$a->Components}; ++$ic ) + { + if ( $cmp = cmp_component($a->Components->[$ic], $b->Components->[$ic]) ) + { return $cmp; } + } + + # no difference found + return 0; +} + +## +## + +sub by_molecule +{ + return cmp_molecule( $a, $b ); +} + + + +### +### +### + + + +# Canonical order for components of molecules +sub cmp_component +{ + my ($a,$b) = @_; + + my $cmp; + + # Lexical comparison of name + if ( $cmp = ($a->Name cmp $b->Name) ) + { return $cmp; } + + # Lexical comparison of state labels + if ( defined $a->State ) + { + unless ( defined $b->State ) { return 1; } + if ( $cmp = ($a->State cmp $b->State) ) + { return $cmp; } + } + elsif ( defined $b->State ) + { + return -1; + } + + # Comparison of number of edges + # NOTE: the usual order of a and b are switched!! + # so the components with more edges are before components with fewer edges + if ( $cmp = ( @{$b->Edges} <=> @{$a->Edges} ) ) + { return $cmp; } + + # Comparison of edges + # for my $i (0..$#a_edges){ + # if ($cmp=($a_edges[$i] cmp $b_edges[$i])){ + # return($cmp); + # } + # } + + # no difference found + return 0; +} + +## +## + +sub by_component +{ + return cmp_component($a, $b); +} + + + + +### +### +### + + + +sub cmp_edge +{ + my ($a,$b) = @_; + + my $cmp; + # split pointers + my (@a_p) = split /[ \.]/, $a; + my (@b_p) = split /[ \.]/, $b; + # dangling edges (2 elements in array) should be "greater than" true edges (4 elements in array) + if ($cmp = (@b_p <=> @a_p)) { return $cmp; } + # if both edges are the same true, compare element by element.. + foreach my $i ( 0 .. $#a_p ) + { + if ( $cmp = ($a_p[$i] <=> $b_p[$i]) ) + { return $cmp; } + } + # Getting here means edges are identical, which shouldn't happen. + return 0; +} + +## +## + +sub by_edge +{ + return cmp_edge($a, $b); +} + + + + +### +### +### + + + + +# This sub assumes edges are stored in array references like this: +# true edges = ((m1, c1), (m2, c2)) +# dangling edges = ((m1, c1)) +# +# Dangling edges are "greater than" True edges. +# +# This is only used by the updateEdges method. + +sub edge_sort +{ + # $a, $b arguments should be array references + my $cmp; + # dangling edges (1 elements in array) should be "greater than" true edges (4 elements in array) + if ($cmp = (@$b <=> @$a)) { return $cmp; } + # if both edges are the same true, otherwise compare element by element.. + for ( my $i=0; $i < @$a; ++$i ) + { + if ( $cmp = ($a->[$i]->[0] <=> $b->[$i]->[0]) ) { return $cmp; } + if ( $cmp = ($a->[$i]->[1] <=> $b->[$i]->[1]) ) { return $cmp; } + } + # Getting here means edges are identical (which shouldn't happen?). + return 0; +} + + + +### +### +### + +1; diff --git a/libvcell/vcell_install/bionetgen/Perl2/SpeciesList.pm b/libvcell/vcell_install/bionetgen/Perl2/SpeciesList.pm new file mode 100644 index 0000000..28c186a --- /dev/null +++ b/libvcell/vcell_install/bionetgen/Perl2/SpeciesList.pm @@ -0,0 +1,820 @@ +# A container class for Species objects +package SpeciesList; + +# pragmas +use strict; +use warnings; + +# Perl Modules +use Class::Struct; + +# BNG Modules +use BNGUtils; +use Species; +use SpeciesGraph; +use MoleculeTypesList; +use ParamList; + + +# Members +struct SpeciesList => +{ + Array => '@', # array of pointers to species + Hash => '%', # a hash map from species' StringID to species pointers + Hash_exact => '%' # a hash map from species' StringExact to species pointers +}; + + + +### +### +### + + +sub getNumSpecies +{ + my $slist = shift; + return scalar @{$slist->Array}; +} + +sub size +{ + my $slist = shift @_; + return scalar @{$slist->Array}; +} + + +### +### +### + + +sub sort +{ + my $slist = shift; + + print "Sorting species list\n"; + my @newarr = sort {$a->SpeciesGraph->StringExact cmp $b->SpeciesGraph->StringExact} @{$slist->Array}; + $slist->Array(\@newarr); + my $ispec = 1; + foreach my $spec ( @{$slist->Array} ) + { + $spec->Index($ispec); + ++$ispec; + } + + return $slist; +} + + + +### +### +### + + + +# Returns pointer to matching species in $slist or undef if no match found +sub lookup +{ + my $slist = shift @_; + my $sg = shift @_; + my $check_iso = @_ ? shift @_ : 1; + + if( $sg->IsCanonical ) { $check_iso = 0; } + + my $spec = undef; + my $sstring = $sg->StringID; + if ( exists $slist->Hash->{$sstring} ) + { + # Since string is not completely canonical, need to check isomorphism with other list members + # Determine whether the graph is isomorphic to any on the current list + if ($check_iso) + { + foreach my $spec2 ( @{$slist->Hash->{$sstring}} ) + { + if ($sg->isomorphicTo($spec2->SpeciesGraph)) + { + $spec = $spec2; + last; + } + } + } + else + { + $spec = $slist->Hash->{$sstring}->[0]; + } + } + return $spec; +} + +# Look up species by StringExact, returns pointer to species or undef if not found. +sub lookup_bystring +{ + my $slist = shift @_; + my $sstring = shift @_; + + my $species = undef; + if ( exists $slist->Hash_exact->{$sstring} ) + { + $species = $slist->Hash_exact->{$sstring}; + } + return $species; +} + +# Look up species by Index, returns pointer to species or undef if not found. +sub lookup_by_index +{ + my ($slist, $idx) = @_; + my $species = undef; + if ( exists $slist->Array->[$idx-1] and defined $slist->Array->[$idx-1] ) + { $species = $slist->Array->[$idx-1]; } + return $species; +} + + +# Returns reference to Species object either newly created or found in $slist +# Should check if species already exists in list before adding +sub add +{ + my $slist = shift @_; + my $sg = shift @_; + my $conc = @_ ? shift @_ : 0; + + # Create new species from SpeciesGraph + my $spec = Species->new; + push @{$slist->Array}, $spec; + push @{$slist->Hash->{$sg->StringID}}, $spec; + # Can only be one entry. TODO: generate exit_error if there is a clash! + $slist->Hash_exact->{$sg->StringExact} = $spec; + $spec->SpeciesGraph($sg); + $spec->Concentration($conc); + $spec->Index( scalar @{$slist->Array} ); + $spec->RulesApplied(0); + # Put ref to species in SpeciesGraph to bind it + $sg->Species($spec); + + return $spec; +} + +sub remove +{ + my $slist = shift @_; + my $spec = shift @_; + + # Remove from Array + splice( @{$slist->Array}, $spec->Index-1, 1 ); + + # Remove from Hash + my $harray = $slist->Hash->{$spec->SpeciesGraph->StringID}; + foreach my $i (0..$#$harray) + { + if ($spec == $harray->[$i]) + { + splice( @$harray, $i, 1 ); + unless (@$harray) + { + undef $slist->Hash->{$spec->SpeciesGraph->StringID}; + } + last; + } + } + + # Remove from Hash_exact + undef $slist->Hash_exact->{$spec->SpeciesGraph->StringExact}; + + return; +} + + + +# Read entry from input species block +sub readString +{ + my $slist = shift @_; + my $string = shift @_; + my $plist = shift @_; + my $clist = shift @_; + my $mtlist = shift @_; + + my ($conc, $sg, $err); + + my $name = ''; + + # remove leading index + $string =~ s/^\s*\d+\s+//; # Can't deprecate this because indices used in NET files + + # Remove leading label, if any + if ($string =~ s/^\s*(\w+)\s*:\s+//) + { + # Check label for leading number + my $label = $1; + if ($label =~ /^\d/) { return "Syntax error (label begins with a number) at '$label'."; } + } + + # Read species string + $sg = SpeciesGraph->new; + $string =~ s/^\s+//; + $err = $sg->readString( \$string, $clist, 1, '^\s+', $mtlist ); + if ($err) { return $err; } + + if ( $sg->isNull() ) + { # this is the null pattern + send_warning( "Found useless instance of null pattern in SpeciesList" ); + return ''; + } + + # Check if isomorphic to existing species + my $existing= $slist->lookup($sg); + if ($existing) + { + my $sstring = $sg->StringExact; + my $index = $existing->Index; + return "Species $sstring isomorphic to previously defined species index $index"; + } + + # Read species concentration as math expression. + # Set species concentration to number or variable name. + if ( $string =~ /\S+/ ) + { + # Read expression + my $expr = Expression->new(); + if ( my $err = $expr->readString(\$string, $plist) ) { return ('', $err); } + # AS2023 - we need to check to ensure species does not refer + # to observables or functions block since they aren't evaluated + # during initialization and will cause `run_network`` to fail. + my $dependencies = $expr->getVariables($plist); + if ( exists $dependencies->{'Observable'} + or exists $dependencies->{'Function'} ) + { + my $spec_str = $sg->toString(); + my $err = "Error while parsing species block, in species: $spec_str. "; + $err .= "Found species expressions that refer to observables or functions. "; + $err .= "This is not allowed, quitting!"; + return ('', $err); + } + # done checking dependencies + if ( $expr->Type eq 'NUM' ) + { + $conc = $expr->evaluate(); + } + else + { + $conc = $expr->getName( $plist, '_InitialConc' ); + } + } + else + { + return "Species is missing expression for population or concentration"; + } + + # Create new Species entry in SpeciesList + $slist->add($sg, $conc); + + return ''; +} + + + +### +### +### + + +# string = $slist->writeBNGL( *Array, [*ParamList, bool, *Hash] ) +sub writeBNGL +{ + my $slist = shift @_; + my $conc = @_ ? shift @_ : []; + my $plist = @_ ? shift @_ : undef; + my $user_params = @_ ? shift @_ : { 'TextSpecies'=>0, 'pretty_formatting'=>0 }; + + # this method loads @$conc with initial conditions (if @$conc is empty) + # OR checks that @$conc is okay (if @$conc has elements) + $slist->checkOrInitConcentrations($conc); + + ## Determine length of longest species string + #my $maxlen = 0; + #foreach my $spec ( @{$slist->Array} ) + #{ + # my $len = 1; + # $len += defined $spec->SpeciesGraph->Name ? length $spec->SpeciesGraph->Name : 0; + # $len += defined $spec->SpeciesGraph->StringExact ? length $spec->SpeciesGraph->StringExact : 0; + # $maxlen = ($len > $maxlen) ? $len : $maxlen; + #} + + my $out .= "begin species\n"; + foreach my $spec ( @{$slist->Array} ) + { + if ( $user_params->{'pretty_formatting'} ) + { # no species index, ident + $out .= ' '; + } + else + { # include index + $out .= sprintf "%5d ", $spec->Index; + } + + # get species graph string +# my $sexact = $spec->SpeciesGraph->toString(); + if ($user_params->{'TextSpecies'}){ + $out .= sprintf "%s", $spec->SpeciesGraph->toString(); + } + else{ + $out .= sprintf "S%d", $spec->Index; + } + #$out .= sprintf "%-${maxlen}s", $sexact; +# $out .= sprintf "%s", $sexact; + + my $c = $conc->[ $spec->Index - 1 ]; + $out .= sprintf " %s\n", $c; + } + $out .= "end species\n"; + + return $out; +} + + + +### +### +### + + + +sub writeSSC +{ + my $slist = shift @_; + my $conc = @_ ? shift @_ : []; + my $plist = @_ ? shift @_ : undef; + my $print_names = @_ ? shift : 0; + + my $string = ''; + + # this method loads @$conc with initial conditions (if @$conc is empty) + # OR checks that @$conc is okay (if @$conc has elements) + $slist->checkOrInitConcentrations($conc); + + my $idx=0; + foreach my $spec (@{$slist->Array}) + { + my $sname; + my $sexact= $spec->SpeciesGraph->toStringSSCMol(); + $sname=$sexact; + $string .= "new $sname at "; + my $c; + $c = $conc->[$idx]; + $string .= $c; + $string.= "\n"; + ++$idx; + } + + return $string; +} + + +sub print +{ + my $slist = shift @_; + my $fh = shift @_; + my $i_start = @_ ? shift : 0; + + print $fh "begin species\n"; + foreach my $i ( $i_start..$#{$slist->Array} ) + { + my $spec = $slist->Array->[$i]; + printf $fh "%5d %s %s\n", $i-$i_start+1, $spec->SpeciesGraph->StringExact, $spec->Concentration; + } + print $fh "end species\n"; + return ''; +} + +sub toXML +{ + my $slist = shift @_; + my $indent = @_ ? shift @_ : ""; + # Use concentration array if provided + my $conc = @_ ? shift @_ : []; + + # this method loads @$conc with initial conditions (if @$conc is empty) + # OR checks that @$conc is okay (if @$conc has elements) + $slist->checkOrInitConcentrations($conc); + + my $string = $indent . "\n"; + + my $i=0; + foreach my $spec (@{$slist->Array}) + { + $string.= $spec->toXML(" ".$indent, $conc->[$i]); + ++$i; + } + + $string .= $indent."\n"; + return $string; +} + +sub toSBMLMulti +{ + my $slist = shift @_; + my $indent = @_ ? shift @_ : ""; + my $conc = @_ ? shift @_ : []; + + # this method loads @$conc with initial conditions (if @$conc is empty) + # OR checks that @$conc is okay (if @$conc has elements) + $slist->checkOrInitConcentrations($conc); + my $string = $indent . "\n"; + + my $i=0; + foreach my $spec (@{$slist->Array}) + { + $string.= $spec->toSBMLMulti(" ".$indent, $conc->[$i], $i); + ++$i; + } + + $string .= $indent."\n"; + return $string; + +} + +sub toSBMLMultiType +{ + my $slist = shift @_; + my $mtlist = shift @_; + my $indent = @_ ? shift @_ : ""; + + my $string = $indent . "\n"; + my $i=0; + + my %sbmlMultiSpeciesTypeInfo; + + foreach my $spec (@{$slist->Array}) + { + #each call returns the individual species type entry for this string and associated species + $string.= $spec->toSBMLMultiType($mtlist, " ".$indent, \%sbmlMultiSpeciesTypeInfo); + #attach child species types + + ++$i; + + } + foreach my $ostr (@{$sbmlMultiSpeciesTypeInfo{'speciesType'}}){ + $string .= " " . $indent . $ostr; + } + + #walk through sbmlmultispeciesinfo and write species type + $string .= $indent."\n"; + return $string; +} + + +### +### +### +sub writeMDL +{ + my $slist = shift @_; + my $model = shift @_; + my $indent = shift @_; + my $py_species = shift @_; + my $py_param = shift @_; + + my $string = ""; + my $tpy_param = {}; + my @tpy_keys = ('name','value','unit','type'); + # Define diffusion constants for compartments + $string .= $indent."T = 298.15 /* Temperature, K */\n"; + $tpy_param = {'name'=>"T",'value'=>"298.25",'unit'=>"K",'type'=>""}; + push(@{$py_param},"{".join(",",map("\"$_\"".":\"".$tpy_param->{$_}."\"", @tpy_keys))."}"); + + if (@{$model->CompartmentList->Array}) { + $string .= $indent."h = rxn_layer_t /* Thickness of 2D compartment, um */\n"; + $tpy_param = {'name'=>"h",'value'=>"rxn_layer_t",'unit'=>"um",'type'=>""}; + push(@{$py_param},"{".join(",",map("\"$_\"".":\"".$tpy_param->{$_}."\"", @tpy_keys))."}"); + } + $string .= $indent."Rs = 0.002564 /* Radius of a (spherical) molecule in 3D compartment, um */\n"; + $tpy_param = {'name'=>"Rs",'value'=>"0.002564",'unit'=>"um",'type'=>""}; + push(@{$py_param},"{".join(",",map("\"$_\"".":\"".$tpy_param->{$_}."\"", @tpy_keys))."}"); + + if (@{$model->CompartmentList->Array}) { + $string .= $indent."Rc = 0.0015 /* Radius of a (cylindrical) molecule in 2D compartment, um */\n"; + $tpy_param = {'name'=>"Rc",'value'=>"0.0015",'unit'=>"um",'type'=>""}; + push(@{$py_param},"{".join(",",map("\"$_\"".":\"".$tpy_param->{$_}."\"", @tpy_keys))."}"); + } + + $string .= $indent."gamma = 0.5722 /* Euler's constant */\n"; + $tpy_param = {'name'=>"gamma",'value'=>"0.5722",'unit'=>"",'type'=>"Euler's constant"}; + push(@{$py_param},"{".join(",",map("\"$_\"".":\"".$tpy_param->{$_}."\"", @tpy_keys))."}"); + $string .= $indent."KB = 1.3806488e-19 /* Boltzmann constant, cm^2.kg/K.s^2 */\n"; + $tpy_param = {'name'=>"KB",'value'=>"1.3806488e-19",'unit'=>"cm^2.kg/K.s^2",'type'=>"Boltzmann constant"}; + push(@{$py_param},"{".join(",",map("\"$_\"".":\"".$tpy_param->{$_}."\"", @tpy_keys))."}"); + + my %difconst = (); + my %difexp = (); + if (@{$model->CompartmentList->Array}){ + foreach my $comp (@{$model->CompartmentList->Array}){ + if ($comp->SpatialDimensions == 3){ + $difexp{$comp} = "KB*T/(6*PI*mu_".$comp->Name."*Rsp)" ; + } + + + if ($comp->SpatialDimensions == 2){ + my $vi = ""; + my $vo = ""; + my $vavg = ""; + + if (@{$comp->Inside}){ + foreach (@{$comp->Inside}){ + if ($_->Outside == $comp){ + $vi = "mu_".$_->Name; + last; + } + } + } + + if ($comp->Outside){ + $vo = "mu_".$comp->Outside->Name; + } + + if (($vi eq "")&&($vo eq "")){ + $vavg = "mu_".$comp->Name; + } + elsif (($vi eq "")&&($vo ne "")){ + $vavg = $vo; + } + elsif (($vi ne "")&&($vo eq "")){ + $vavg = $vi; + } + else{ + $vavg = "(".$vo."+".$vi.")/2"; + } + + $difexp{$comp} = "KB*T*LOG((mu_".$comp->Name."*h/(Rsp*".$vavg."))-gamma)/(4*PI*mu_".$comp->Name."*h)"; + } + + my $tstring = "$indent"."mu_".$comp->Name; + $string .= $tstring." = 1e-9 /* Viscosity in compartment ".$comp->Name.", kg/um.s */\n"; + $tpy_param = {'name'=>"mu_".$comp->Name,'value'=>"1e-9",'unit'=>"kg/um.s",'type'=>"viscosity"}; + push(@{$py_param},"{".join(",",map("\"$_\"".":\"".$tpy_param->{$_}."\"", @tpy_keys))."}"); + } + } + else { + $string .= $indent."mu = 1e-9\n"; # Default viscosity + } + + $difconst{"DEFAULT"} = "DIF"; + $difexp{"DEFAULT"} = "KB*T/(6*PI*mu"."*Rsp)"; + + $string .= "\nDEFINE_MOLECULES\n{\n"; + foreach my $spec (@{$slist->Array}){ + $string .= $indent.$spec->writeMDL(\%difexp,$py_species,$py_param); + } + + $string .= "}\n"; + return $string; +} +### +### +### + + +sub toCVodeString +{ + my $slist = shift; + my $rlist = shift; + my $stoich_hash = shift; + my $plist = (@_) ? shift : undef; + + my $deriv_defs = ''; + my $indent = ' '; + my $err; + + # construct derivative definition for each species + foreach my $species ( @{ $slist->Array } ) + { + # get species vector in stoich hash + my $species_vector = $stoich_hash->{ $species->Index }; + my $species_deriv = ''; + + if ( $species->SpeciesGraph->Fixed ) + { # handle species with fixed population + $species_deriv = 0.0; + } + else + { # handle all other species... + # add rates and stoich for each reaction that influences this speices + foreach my $i_rxn ( sort { $a <=> $b } keys %$species_vector ) + { + # get species stoichiometry under this reaction + my $stoich = $species_vector->{$i_rxn}; + + # look up reaction object + my $i_rxn0 = $i_rxn - 1; + my $rxn = $rlist->Array->[$i_rxn0]; + + # add this reaction flux to the species derivative + if ( $stoich == 1 ) + { $species_deriv .= " +" . $rxn->getCVodeName(); } + elsif ( $stoich == 0 ) + { } + elsif ( $stoich == -1 ) + { $species_deriv .= " -" . $rxn->getCVodeName(); } + elsif ( $stoich > 0 ) + { $species_deriv .= " +$stoich.0*" . $rxn->getCVodeName(); } + elsif ( $stoich < 0 ) + { $species_deriv .= " $stoich.0*" . $rxn->getCVodeName(); } + } + + # trim leading " +" + $species_deriv =~ s/^ \+?//; + + # replace empty string with a zero rate + if ($species_deriv eq '') + { $species_deriv = '0.0'; } + } + + # add derivative to list of definitions + $deriv_defs .= $indent . $species->getCVodeDerivName() . " = $species_deriv;\n"; + } + + return ( $deriv_defs, $err ); +} + + +### +### +### + + +sub toMatlabString +{ + my $slist = shift; + my $rlist = shift; + my $stoich_hash = shift; + my $plist = (@_) ? shift : undef; + + my $deriv_defs = ''; + my $indent = ' '; + my $err; + + # construct derivative definition for each species + foreach my $species ( @{ $slist->Array } ) + { + # get species vector in stoich hash + my $species_vector = $stoich_hash->{ $species->Index }; + my $species_deriv = ''; + + if ( $species->SpeciesGraph->Fixed ) + { # handle species with fixed population + $species_deriv = '0.0'; + } + else + { # handle all other species... + # add rates and stoich for each reaction that influences this speices + foreach my $i_rxn ( sort { $a <=> $b } keys %$species_vector ) + { + # get species stoichiometry under this reaction + my $stoich = $species_vector->{$i_rxn}; + + # look up reaction object + my $i_rxn0 = $i_rxn - 1; + my $rxn = $rlist->Array->[$i_rxn0]; + + # add this reaction flux to the species derivative + if ( $stoich == 1 ) + { $species_deriv .= " +" . $rxn->getMatlabName(); } + elsif ( $stoich == 0 ) + { } + elsif ( $stoich == -1 ) + { $species_deriv .= " -" . $rxn->getMatlabName(); } + elsif ( $stoich > 0 ) + { $species_deriv .= " +$stoich.0*" . $rxn->getMatlabName(); } + elsif ( $stoich < 0 ) + { $species_deriv .= " $stoich.0*" . $rxn->getMatlabName(); } + } + + # trim leading " +" + $species_deriv =~ s/^ \+?//; + + # replace empty string with a zero rate + if ($species_deriv eq '') + { $species_deriv = '0.0'; } + } + + # add derivative to list of definitions + $deriv_defs .= $indent . $species->getMatlabDerivName() . " = $species_deriv;\n"; + } + + return ( $deriv_defs, $err ); +} + + +### +### +### + + +# get names of species and formulas for initial concentrations for matlab +# NOTE: this method ALWAYS writes the original initial concentration definitions +# and ignores any changes made by setConcentrations +sub getMatlabSpeciesNames +{ + my $slist = shift @_; + my $model = shift @_; + + my $plist = $model->ParamList; + + my $err; + my $species_names = ''; + my $species_init = ''; + my $indent = ' '; + + # TODO: this matlab output is a hack. improve this. --justin + + # generate a map from param names to matlab references + my $ref_map = {}; + my $m_idx = 1; + foreach my $param ( @{$plist->Array} ) + { + if ( $param->Type eq 'Constant' ) + { + $ref_map->{ $param->Name } = "params($m_idx)"; + ++$m_idx; + } + } + + # gather names and init expressions for all species + $m_idx = 1; + my @species_names = (); + foreach my $species ( @{ $slist->Array } ) + { + push @species_names, "'" . $species->SpeciesGraph->StringExact . "'"; + (my $param) = $plist->lookup( $species->Concentration ); + + if ( $param ) + { # initial concentration is given by a Parameter + # expand the expression (recursively past parameters!) + $species_init .= $indent . "species_init($m_idx) = " . $param->toString( $plist, 0, 2 ) . ";\n"; + } + else + { # initial concentration is a number + $species_init .= $indent . "species_init($m_idx) = " . $species->Concentration . ";\n"; + } + ++$m_idx; + } + + # replace param names with Matlab references + foreach my $pname ( keys %$ref_map ) + { + my $matlab_ref = $ref_map->{$pname}; + my $regex = + $species_init =~ s/(^|\W)$pname(\W|$)/$1$matlab_ref$2/g; + } + + return ( join(', ', @species_names), $species_init, $err ); +} + +sub getMatlabSpeciesNamesOnly +{ + my $slist = shift; + my $err; + my @species_names = (); + foreach my $species ( @{ $slist->Array } ) + { + push @species_names, "'" . $species->SpeciesGraph->StringExact . "'"; + } + + return ( join(', ', @species_names), $err ); + +} + +# Check or initialize a species concentration vector: If @$cond is empty, it is loaded +# with species concentrations from the SpeciesList. If @$conc is non-empty, then +# it's checked for size compatibility with SpeciesList. If @$conc is shorter than the +# SpeciesList, it is padded with zeros. If @$conc is longer, it's an error. +# +# $slist->checkOrInitConcentrations( $conc ) +sub checkOrInitConcentrations +{ + my $slist = shift @_; + my $conc = shift @_; + + # decide to use concentration vector or direct values from species + if ( @$conc ) + { # check concentration vector + if ( @$conc > @{$slist->Array} ) + { # this case is not well-defined + exit_error( "SpeciesList->initConcentrations(): concentration array is longer than species array" ); + } + elsif ( @$conc < @{$slist->Array} ) + { # pad with zeros + my $n_zeros = @{$slist->Array} - @$conc; + push @$conc, (0) x $n_zeros; + } + } + else + { # get concentrations from species + @$conc = map {$_->Concentration} @{$slist->Array}; + } +} + + +1; diff --git a/libvcell/vcell_install/bionetgen/Perl2/Visualization/ContactMap.pm b/libvcell/vcell_install/bionetgen/Perl2/Visualization/ContactMap.pm new file mode 100644 index 0000000..89c4962 --- /dev/null +++ b/libvcell/vcell_install/bionetgen/Perl2/Visualization/ContactMap.pm @@ -0,0 +1,156 @@ +package Viz; + +use strict; +use warnings; +no warnings 'redefine'; + +use Class::Struct; +use Visualization::NetworkGraph; +use Visualization::StructureGraph; +use Visualization::Viz; + + +struct ContactMap => +{ + 'MType' => '%', + 'Bonds' => '@', + 'ReacProds' => '%', + 'Names' => '%', +}; + + + + +sub makeContactMap +{ + my @bpgs = @{shift @_}; + my @statepatternlist = @{shift @_}; + + my @ap = uniq (map { + my $bpg = $_; + grep { $bpg->{'NodeType'}->{$_} eq 'AtomicPattern' } + @{$bpg->{'NodeList'}}; + } @bpgs); + + + #my @ap = uniq ((@ap1,@ap2)); + + my %cmap; + my @bonds; + + # assigning mols + my @mols = grep !/\(/, @ap; + foreach my $mol(@mols) { $cmap{$mol} = {}; }; + + + # assigning comps + my @comps = grep !/~/, + grep !/\!/, + grep /\(/, + @ap; + foreach my $str(@comps) + { + $str =~ /(.*)\((.*)\)/; + my @arr = (); + $cmap{$1}{$2} = \@arr; + } + foreach my $str(@statepatternlist) + { + $str =~ /(.*)\((.*)~(.*)\)/; + my @arr = (); + $cmap{$1}{$2} = \@arr; + } + + + # assigning comp states + my @compstates = grep /~/,uniq(@ap,@statepatternlist); + foreach my $str(@compstates) + { + $str =~ /(.*)\((.*)~(.*)\)/; + #push $cmap{$1}{$2}, $3; + push2ref($cmap{$1}{$2},$3); + } + + # getting bonds + my @bondstates = grep !/\!\+/, + grep /\!/, @ap; + foreach my $bond(@bondstates) + { + my @splits = split /\./, $bond; + $splits[0] =~ /(.*)\((.*)\!/; + my $mol1 = $1; + my $comp1 = $2; + $splits[1] =~ /(.*)\((.*)\!/; + my $mol2 = $1; + my $comp2 = $2; + push @bonds, $mol1." ".$comp1." ".$mol2." ".$comp2; + + if(!exists $cmap{$mol1}) {$cmap{$mol1} = {};} + if(!exists $cmap{$mol2}) {$cmap{$mol1} = {};} + if(!exists $cmap{$mol1}{$comp1}) { my @arr = (); $cmap{$mol1}{$comp1} = \@arr;} + if(!exists $cmap{$mol2}{$comp2}) { my @arr = (); $cmap{$mol2}{$comp2} = \@arr;} + + } + + + # building the contact map + my @new_nodes = (); + my $mol_ind = -1; + foreach my $mol(sort keys %cmap) + { + $mol_ind++; + push @new_nodes, makeNode('Mol',$mol,$mol_ind); + my $comp_ind = -1; + foreach my $comp (sort keys %{$cmap{$mol}}) + { + $comp_ind++; + my $c_id = $mol_ind.".".$comp_ind; + my @parents = ($mol_ind); + push @new_nodes, makeNode('Comp',$comp,$c_id,\@parents); + my $state_ind = -1; + foreach my $compstate(@{$cmap{$mol}{$comp}}) + { + $state_ind++; + my $id = $mol_ind.".".$comp_ind.".".$state_ind; + my @parents = ($c_id); + push @new_nodes, makeNode('CompState',$compstate,$id,\@parents); + } + } + } + + foreach my $bond(@bonds) + { + my @splits = split " ",$bond; + my $comp1 = findComp(\@new_nodes,$splits[0],$splits[1]); + my $comp2 = findComp(\@new_nodes,$splits[2],$splits[3]); + my @parents = sort ($comp1,$comp2); + my $id = $parents[0].".1"; + push @new_nodes,makeNode('BondState',"+",$id,\@parents); + } + + my $psg = makeStructureGraph('ContactMap',\@new_nodes); + #print printStructureGraph($psg); + return $psg; +} + +sub findComp +{ + my @nodelist = @{shift @_}; + my $molname = shift @_; + my $compname = shift @_; + my @nodes = grep $_->{'Name'} eq $molname, + grep $_->{'Type'} eq 'Mol', + grep $_->{'Type'} eq 'Mol', + @nodelist; + my $mol_id = $nodes[0]->{'ID'}; + @nodes = grep has($_->{'Parents'},$mol_id), + grep $_->{'Name'} eq $compname, + grep $_->{'Type'} eq 'Comp', + @nodelist; + + return $nodes[0]->{'ID'}; +} + + + +1; \ No newline at end of file diff --git a/libvcell/vcell_install/bionetgen/Perl2/Visualization/GML.pm b/libvcell/vcell_install/bionetgen/Perl2/Visualization/GML.pm new file mode 100644 index 0000000..f97089c --- /dev/null +++ b/libvcell/vcell_install/bionetgen/Perl2/Visualization/GML.pm @@ -0,0 +1,2111 @@ +package Viz; + +use strict; +use warnings; +no warnings 'redefine'; + +# Perl Modules +use Class::Struct; + +# BNG Modules +use Visualization::StructureGraph; + +# basic structures and methods +struct GMLNode => +{ + 'ID' => '$', + 'type' => '$', + 'label' => '$', + 'fill' => '$', + 'outlineStyle' => '$', + 'fontStyle' => '$', + 'anchor'=>'$', + 'object'=>'$', + 'isGroup'=>'$', + 'gid'=>'$', + 'hasOutline' => '$', + 'outline'=>'$', + 'embed'=>'$' +}; + +struct GMLEdge => +{ + 'source' => '$', + 'target' => '$', + 'fill' => '$', + 'sourceArrow' => '$', + 'targetArrow' => '$', + 'object' => '$' +}; + +struct GMLGraph => +{ + 'Nodes'=>'@', + 'Edges'=>'@', +}; + +# new versions of things +struct NodeGML => +{ + 'ID' => '$', + 'label' => '$', + 'gid' => '$', + 'isGroup' => '$', + + 'graphics' => '$', + 'LabelGraphics' => '$', + + 'object' =>'$', + 'embed' => '$' +}; + +struct NodeGraphicsGML => +{ + 'type' => '$', + 'fill' => '$', + 'hasOutline' => '$', + 'outlineWidth' => '$', + 'outlineStyle' => '$', + 'outline' => '$', +}; + +struct LabelGraphicsGML => +{ + 'text' => '$', + 'fontSize' => '$', + 'fontName' => '$', + 'fontStyle' => '$', + 'anchor' => '$', +}; + +struct EdgeGML => +{ + 'source'=> '$', + 'target'=> '$', + 'object'=> '$', + 'graphics' => '$' +}; + +struct EdgeGraphicsGML => +{ + 'width' => '$', + 'style' => '$', + 'fill' => '$', + 'sourceArrow' => '$', + 'targetArrow' => '$' +}; + +sub newnode +{ + my ($id,$label,$object) = @_; + my $gmlnode = NodeGML->new(); + $gmlnode->{'ID'} = $id; + $gmlnode->{'label'} = $label; + $gmlnode->{'object'} = $object; + $gmlnode->{'isGroup'} = 0; + $gmlnode->{'gid'} = ""; + my $graphics = NodeGraphicsGML->new(); + $graphics->{'type'} = "ellipse"; + $graphics->{'fill'} = "#CCCCFF"; + $gmlnode->{'graphics'} = $graphics; + $graphics->{'hasOutline'} = "0"; + $graphics->{'outlineWidth'} = "1"; + $graphics->{'outlineStyle'} = "line"; + $graphics->{'outline'} = "#CCCCFF"; + my $labelgraphics = LabelGraphicsGML->new(); + $labelgraphics->{'text'} = $label; + $labelgraphics->{'fontSize'} = "12"; + $labelgraphics->{'fontName'} = "Dialog"; + $labelgraphics->{'fontStyle'} = "plain"; + $labelgraphics->{'anchor'} = "c"; + $gmlnode->{'LabelGraphics'} = $labelgraphics; + return $gmlnode; +}; + +sub printnode +{ + my $node = shift @_; + my $q0 = " "; + my $q1 = " \""; + my $q2 = "\" "; + my $q3 = " [ "; + my $q4 = " ] "; + my @nodestrs; + my @strs = (); + push @strs,"id".$q0.$node->{'ID'}.$q0; + push @strs,"label".$q1.$node->{'label'}.$q2; + push @strs,"isGroup".$q0.$node->{'isGroup'}.$q0; + push @strs,($node->{'gid'} ne "") ? "gid".$q0.$node->{'gid'}.$q0 : "gid".$q1.$q2; + push @nodestrs, join(" ",@strs); + @strs = (); + my $graphics = $node->{'graphics'}; + push @strs,"type".$q1.$graphics->{'type'}.$q2; + push @strs,"fill".$q1.$graphics->{'fill'}.$q2; + push @strs,"hasOutline".$q0.$graphics->{'hasOutline'}.$q0; + push @strs,"outlineWidth".$q0.$graphics->{'outlineWidth'}.$q0; + push @strs,"outlineStyle".$q1.$graphics->{'outlineStyle'}.$q2; + push @strs,"outline".$q1.$graphics->{'outline'}.$q2; + push @nodestrs, "graphics".$q3.join(" ",@strs).$q4; + @strs = (); + my $labelgraphics = $node->{'LabelGraphics'}; + push @strs,"text".$q1.$labelgraphics->{'text'}.$q2; + push @strs,"fontSize".$q0.$labelgraphics->{'fontSize'}.$q0; + push @strs,"fontName".$q1.$labelgraphics->{'fontName'}.$q2; + push @strs,"fontStyle".$q1.$labelgraphics->{'fontStyle'}.$q2; + push @strs,"anchor".$q1.$labelgraphics->{'anchor'}.$q2; + push @nodestrs, "LabelGraphics".$q3.join(" ",@strs).$q4; + my $str = "node [\n".join(" ",@nodestrs)."\n ]"; + return $str; +} + +sub newedge +{ + my ($source,$target,$forwardarrow,$reversearrow,$object) = @_; + my $gmledge = EdgeGML->new(); + $gmledge->{'source'} = $source; + $gmledge->{'target'} = $target; + $gmledge->{'object'} = $object; + my $graphics = EdgeGraphicsGML->new(); + $graphics->{'width'} = "1"; + $graphics->{'style'} = "line"; + $graphics->{'fill'} = "#000000"; + $graphics->{'sourceArrow'} = $reversearrow ? "standard" : "none"; + $graphics->{'targetArrow'} = $forwardarrow ? "standard" : "none"; + $gmledge->{'graphics'} = $graphics; + return $gmledge; +}; + +sub printedge +{ + my $edge = shift @_; + my $q0 = " "; + my $q1 = " \""; + my $q2 = "\" "; + my $q3 = " [ "; + my $q4 = " ] "; + my @edgestrs; + my @strs = (); + push @strs,"source".$q0.$edge->{'source'}.$q0; + push @strs,"target".$q0.$edge->{'target'}.$q0; + push @edgestrs, @strs; + @strs = (); + my $graphics = $edge->{'graphics'}; + push @strs,"width".$q0.$graphics->{'width'}.$q0; + push @strs,"style".$q1.$graphics->{'style'}.$q2; + push @strs,"fill".$q1.$graphics->{'fill'}.$q2; + push @strs,"sourceArrow".$q1.$graphics->{'sourceArrow'}.$q2; + push @strs,"targetArrow".$q1.$graphics->{'targetArrow'}.$q2; + push @edgestrs, "graphics".$q3.join(" ",@strs).$q4; + my $str = "edge [\n".join(" ",@edgestrs)."\n ]"; + return $str; +} + +sub style_node_rule_network +{ + my $node = shift @_; + my $nodetype = shift @_; + my $graphtype = shift @_; + my $prop = load_rule_network_nodestyledefaults($nodetype,$graphtype); + foreach my $key(keys %$prop) + { + $node->{'graphics'}->{$key} = $prop->{$key}; + } + $prop = load_rule_network_labelstyledefaults($nodetype,$graphtype); + foreach my $key(keys %$prop) + { + $node->{'LabelGraphics'}->{$key} = $prop->{$key}; + } + return $node; +}; +sub style_edge_rule_network +{ + my $edge = shift @_; + my $edgetype = shift @_; + my $graphtype = shift @_; + my $prop = load_rule_network_edgestyledefaults($edgetype,$graphtype); + + foreach my $key(keys %$prop) + { + $edge->{'graphics'}->{$key} = $prop->{$key}; + } + + return $edge; +}; + +sub style_node_rule_operation +{ + my $node = shift @_; + my $nodetype = shift @_; + my $prop = load_rule_operation_nodestyledefaults($nodetype); + foreach my $key(keys %$prop) + { + $node->{'graphics'}->{$key} = $prop->{$key}; + } + $prop = load_rule_operation_labelstyledefaults($nodetype); + foreach my $key(keys %$prop) + { + $node->{'LabelGraphics'}->{$key} = $prop->{$key}; + } + return $node; +}; + +sub style_edge_rule_operation +{ + my $edge = shift @_; + my $edgetype = shift @_; + + my $prop = load_rule_operation_edgestyledefaults($edgetype); + + foreach my $key(keys %$prop) + { + $edge->{'graphics'}->{$key} = $prop->{$key}; + } + + return $edge; +}; + +sub style_node_rule_pattern +{ + my $node = shift @_; + my $nodetype = shift @_; + my $prop = load_rule_pattern_nodestyledefaults($nodetype); + foreach my $key(keys %$prop) + { + $node->{'graphics'}->{$key} = $prop->{$key}; + } + $prop = load_rule_pattern_labelstyledefaults($nodetype); + return $node if ($nodetype eq 'Pattern'); + foreach my $key(keys %$prop) + { + $node->{'LabelGraphics'}->{$key} = $prop->{$key}; + } + return $node; +} +sub style_edge_rule_pattern +{ + my $edge = shift @_; + my $edgetype = shift @_; + + my $prop = load_rule_pattern_edgestyledefaults($edgetype); + + foreach my $key(keys %$prop) + { + $edge->{'graphics'}->{$key} = $prop->{$key}; + } + + return $edge; +}; + +sub style_node_rinf +{ + my $node = shift @_; + my $nodetype = shift @_; + my $prop = load_rinf_nodestyledefaults($nodetype); + foreach my $key(keys %$prop) + { + $node->{'graphics'}->{$key} = $prop->{$key}; + } + $prop = load_rinf_labelstyledefaults($nodetype); + foreach my $key(keys %$prop) + { + $node->{'LabelGraphics'}->{$key} = $prop->{$key}; + } + return $node; +}; +sub style_edge_rinf +{ + my $edge = shift @_; + my $edgetype = shift @_; + my $prop = load_rinf_edgestyledefaults($edgetype); + + foreach my $key(keys %$prop) + { + $edge->{'graphics'}->{$key} = $prop->{$key}; + } + + return $edge; +}; + + +sub load_rule_pattern_nodestyledefaults +{ + my $nodetype = shift @_; + my %convert = ('Mol'=>'Molecule', + 'Comp'=>'Component', + 'CompState'=>'InternalState', + 'Pattern'=>'Pattern', + 'Rule'=>'Rule' ); + + my %normal = + ( + 'Molecule' => {'hasOutline'=>"1",'type'=>"ellipse",'fill'=>"#EFEFEF", + 'outlineWidth'=>"1",'outlineStyle'=>"line",'outline'=>"#999999"}, + 'Component' => {'hasOutline'=>"1",'type'=>"ellipse",'fill'=>"#EFEFEF", + 'outlineWidth'=>"1",'outlineStyle'=>"line",'outline'=>"#999999"}, + 'InternalState' => {'hasOutline'=>"1",'type'=>"ellipse",'fill'=>"#FFF0A7", + 'outlineWidth'=>"1",'outlineStyle'=>"line",'outline'=>"#999999"}, + 'Rule' => {'hasOutline'=>"1",'type'=>"ellipse",'fill'=>"#CC99FF", + 'outlineWidth'=>"1",'outlineStyle'=>"line",'outline'=>"#999999"}, + 'Pattern' => {'hasOutline'=>"1",'type'=>"roundrectangle",'fill'=>"#FFFFFF", + 'outlineWidth'=>"1",'outlineStyle'=>"line",'outline'=>"#999999"}, + ); + return $normal{$convert{$nodetype}}; +} + +sub load_rule_pattern_labelstyledefaults +{ + my $nodetype = shift @_; + my %convert = ('Mol'=>'Molecule', + 'Comp'=>'Component', + 'CompState'=>'InternalState', + 'Pattern'=>'Pattern', + 'Rule'=>'Rule' ); + my %normal = + ( + 'Molecule' => {'fontSize'=>"14",'fontName'=>"Dialog",'fontStyle'=>"bold",'anchor'=>"t"}, + 'Component' => {'fontSize'=>"14",'fontName'=>"Dialog",'fontStyle'=>"plain",'anchor'=>"t"}, + 'InternalState' => {'fontSize'=>"14",'fontName'=>"Dialog",'fontStyle'=>"plain",'anchor'=>"c"}, + 'Rule' => {'fontSize'=>"14",'fontName'=>"Dialog",'fontStyle'=>"plain",'anchor'=>"c"}, + 'Pattern' => {'fontSize'=>"14",'fontName'=>"Dialog",'fontStyle'=>"bold",'anchor'=>"t"}, + ); + + return $normal{$convert{$nodetype}}; + +} + +sub load_rule_pattern_edgestyledefaults +{ + my $edgetype = shift @_; + my %normal = + ( + 'Bond' => {'width'=>"1",'style'=>"line",'fill'=>"#999999",'sourceArrow'=>"none",'targetArrow'=>"none"}, + 'Reactant' => {'width'=>"1",'style'=>"line",'fill'=>"#000000",'sourceArrow'=>"none",'targetArrow'=>"standard"}, + 'Product' => {'width'=>"1",'style'=>"line",'fill'=>"#000000",'sourceArrow'=>"none",'targetArrow'=>"standard"}, + ); + return $normal{$edgetype}; +} + + +sub load_rule_operation_nodestyledefaults +{ + my $nodetype = shift @_; + my %convert = ('Mol'=>'Molecule', + 'Comp'=>'Component', + 'CompState'=>'InternalState', + 'GraphOp'=>'GraphOperation', + 'Rule'=>'Rule' ); + + my %normal = + ( + 'Molecule' => {'hasOutline'=>"1",'type'=>"ellipse",'fill'=>"#EFEFEF", + 'outlineWidth'=>"1",'outlineStyle'=>"line",'outline'=>"#999999"}, + 'Component' => {'hasOutline'=>"1",'type'=>"ellipse",'fill'=>"#EFEFEF", + 'outlineWidth'=>"1",'outlineStyle'=>"line",'outline'=>"#999999"}, + 'InternalState' => {'hasOutline'=>"1",'type'=>"ellipse",'fill'=>"#FFF0A7", + 'outlineWidth'=>"1",'outlineStyle'=>"line",'outline'=>"#999999"}, + 'GraphOperation' => {'hasOutline'=>"1",'type'=>"ellipse",'fill'=>"#CC99FF", + 'outlineWidth'=>"1",'outlineStyle'=>"line",'outline'=>"#999999"}, + 'Rule' => {'hasOutline'=>"1",'type'=>"roundrectangle",'fill'=>"#FFFFFF", + 'outlineWidth'=>"1",'outlineStyle'=>"line",'outline'=>"#999999"}, + ); + return $normal{$convert{$nodetype}}; +} + +sub load_rule_operation_labelstyledefaults +{ + my $nodetype = shift @_; + my %convert = ('Mol'=>'Molecule', + 'Comp'=>'Component', + 'CompState'=>'InternalState', + 'GraphOp'=>'GraphOperation', + 'Rule'=>'Rule' ); + my %normal = + ( + 'Molecule' => {'fontSize'=>"14",'fontName'=>"Dialog",'fontStyle'=>"bold",'anchor'=>"t"}, + 'Component' => {'fontSize'=>"14",'fontName'=>"Dialog",'fontStyle'=>"plain",'anchor'=>"t"}, + 'InternalState' => {'fontSize'=>"14",'fontName'=>"Dialog",'fontStyle'=>"plain",'anchor'=>"c"}, + 'GraphOperation' => {'fontSize'=>"14",'fontName'=>"Dialog",'fontStyle'=>"plain",'anchor'=>"c"}, + 'Rule' => {'fontSize'=>"14",'fontName'=>"Dialog",'fontStyle'=>"plain",'anchor'=>"t"}, + ); + + return $normal{$convert{$nodetype}}; + +} + +sub load_rule_operation_edgestyledefaults +{ + my $edgetype = shift @_; + my %normal = + ( + 'Bond' => {'width'=>"1",'style'=>"line",'fill'=>"#999999",'sourceArrow'=>"none",'targetArrow'=>"none"}, + 'Reactant' => {'width'=>"1",'style'=>"line",'fill'=>"#000000",'sourceArrow'=>"none",'targetArrow'=>"standard"}, + 'Product' => {'width'=>"1",'style'=>"line",'fill'=>"#000000",'sourceArrow'=>"none",'targetArrow'=>"standard"}, + ); + return $normal{$edgetype}; +} + +sub load_rule_network_nodestyledefaults +{ + my $nodetype = shift @_; + my $graphtype = shift @_; + my %normal = + ( + 'Rule' => {'hasOutline'=>"1",'type'=>"ellipse",'fill'=>"#CC99FF", + 'outlineWidth'=>"1",'outlineStyle'=>"line",'outline'=>"#999999"}, + 'RuleGroup' => {'hasOutline'=>"1",'type'=>"ellipse",'fill'=>"#E5CBFF", + 'outlineWidth'=>"1",'outlineStyle'=>"line",'outline'=>"#999999"}, + 'AtomicPattern' => {'hasOutline'=>"1",'type'=>"roundrectangle",'fill'=>"#FFE9C7", + 'outlineWidth'=>"1",'outlineStyle'=>"line",'outline'=>"#999999"}, + 'PatternGroup' => {'hasOutline'=>"1",'type'=>"roundrectangle",'fill'=>"#FFF4E3", + 'outlineWidth'=>"1",'outlineStyle'=>"line",'outline'=>"#999999"}, + ); + return $normal{$nodetype}; +}; +sub load_rule_network_labelstyledefaults +{ + my $nodetype = shift @_; + my $graphtype = shift @_; + + my %normal = + ( + 'Rule' => {'fontSize'=>"14",'fontName'=>"Dialog",'fontStyle'=>"plain",'anchor'=>"c"}, + 'RuleGroup' => {'fontSize'=>"14",'fontName'=>"Dialog",'fontStyle'=>"bold",'anchor'=>"c"}, + 'AtomicPattern' => {'fontSize'=>"14",'fontName'=>"Dialog",'fontStyle'=>"plain",'anchor'=>"c"}, + 'PatternGroup' => {'fontSize'=>"14",'fontName'=>"Dialog",'fontStyle'=>"bold",'anchor'=>"c"}, + ); + + return $normal{$nodetype}; +}; +sub load_rule_network_edgestyledefaults +{ + my $edgetype = shift @_; + my $graphtype = shift @_; + my %normal = + ( + 'Reactant' => {'width'=>"1",'style'=>"line",'fill'=>"#000000",'sourceArrow'=>"none",'targetArrow'=>"standard"}, + 'Product' => {'width'=>"1",'style'=>"line",'fill'=>"#000000",'sourceArrow'=>"none",'targetArrow'=>"standard"}, + 'Context' => {'width'=>"1",'style'=>"line",'fill'=>"#AAAAAA",'sourceArrow'=>"none",'targetArrow'=>"standard"}, + 'Inhibition' => {'width'=>"1",'style'=>"line",'fill'=>"#FF0000",'sourceArrow'=>"none",'targetArrow'=>"crows_foot_one"}, + ); + return $normal{$edgetype}; +}; + + +sub load_rinf_nodestyledefaults +{ + my $nodetype = shift @_; + my %normal = + ( + 'Rule' => {'hasOutline'=>"1",'type'=>"ellipse",'fill'=>"#CC99FF", + 'outlineWidth'=>"1",'outlineStyle'=>"line",'outline'=>"#999999"}, + ); + return $normal{$nodetype}; +}; +sub load_rinf_labelstyledefaults +{ + my $nodetype = shift @_; + my %normal = + ( + 'Rule' => {'fontSize'=>"14",'fontName'=>"Dialog",'fontStyle'=>"plain",'anchor'=>"c"}, + ); + + return $normal{$nodetype}; +}; +sub load_rinf_edgestyledefaults +{ + my $edgetype = shift @_; + my %normal = + ( + 'Activation' => {'width'=>"1",'style'=>"line",'fill'=>"#66FF66",'sourceArrow'=>"none",'targetArrow'=>"standard"}, + 'Inhibition' => {'width'=>"1",'style'=>"line",'fill'=>"#FF9999",'sourceArrow'=>"none",'targetArrow'=>"standard"}, + 'Modulation' => {'width'=>"1",'style'=>"line",'fill'=>"#999999",'sourceArrow'=>"none",'targetArrow'=>"standard"}, + ); + return $normal{$edgetype}; +}; + + + +sub copyhash +{ + my %hash = @_; + my %newhash = %hash; + return \%newhash; +}; + +# old versions +sub initializeGMLNode +{ + my $id = shift @_; + my $label = shift @_; + my $object = shift @_; + + my $gmlnode = GMLNode->new(); + $gmlnode->{'ID'} = $id; + $gmlnode->{'label'} = $label; + $gmlnode->{'object'} = $object; + + $gmlnode->{'fill'} = "#FFFFFF"; + $gmlnode->{'outlineStyle'} = ""; + $gmlnode->{'fontStyle'} = ""; + $gmlnode->{'anchor'} = "c"; + $gmlnode->{'isGroup'} = 0; + $gmlnode->{'gid'} = ""; + + return $gmlnode; +} + +sub initializeGMLEdge +{ + my $source = shift @_; + my $target = shift @_; + + #my $object = @_ ? shift @_ : ""; + my $targetArrow = @_ ? shift @_ : 0; + my $sourceArrow = @_ ? shift @_ : 0; + my $object = @_ ? shift @_ : 0; + + my $gmledge = GMLEdge->new(); + $gmledge->{'source'} = $source; + $gmledge->{'target'} = $target; + if ($targetArrow) { $gmledge->{'targetArrow'} = 1;} + if ($sourceArrow) { $gmledge->{'sourceArrow'} = 1;} + if ($object) { $gmledge->{'object'} = $object; } + + return $gmledge; +} + +#### GraphML 1 START ##### +sub printGraphML +{ + my $gmlgraph = shift @_; + my @nodes = @{$gmlgraph->{'Nodes'}}; + my @edges = @{$gmlgraph->{'Edges'}}; + + # start with header and graph + my $allstring = ''."\n"; + $allstring .= '{'gid'} eq '' } @nodes; + my $nctr = 0; + foreach my $pnode(@pnodes) + { + $pnode->{'hierID'} = "n$nctr"; + $nctr += 1; + $allstring .= printGraphMLNode($wc, $pnode, $gmlgraph); + } + + # # Now each edge... + my %edge_id_map = (); + my $edgeid = ''; + my $resolved_source = ''; + my $resolved_target = ''; + my @source = (); + my @target = (); + foreach my $edge(@edges) + { + @source = grep { $_->{'ID'} eq $edge->{'source'} } @nodes; + @target = grep { $_->{'ID'} eq $edge->{'target'} } @nodes; + $resolved_source = $source[0]->{'hierID'}; + $resolved_target = $target[0]->{'hierID'}; + + if (not (defined $edge_id_map{$source[0]->{'ID'}}) ) { $edge_id_map{$source[0]->{'ID'}} = 0}; + + $allstring .= " "x$wc.'{'ID'}} += 1; + $allstring .= 'source="'.$resolved_source.'" '; + $allstring .= 'target="'.$resolved_target.'">'."\n"; + # add data + if (!defined $edge->{'fill'}) { $edge->{'fill'} = "#000000" }; + if (!defined $edge->{'style'}) { $edge->{'style'} = "line" }; + if (!defined $edge->{'width'}) { $edge->{'width'} = "1" }; + if (!defined $edge->{'sourceArrow'}) { $edge->{'sourceArrow'} = "none" }; + if (!defined $edge->{'targetArrow'}) { $edge->{'targetArrow'} = "none" }; + + $allstring .= " "x$wc.''."\n"; # + $allstring .= " "x($wc+2).''."\n"; # + $allstring .= " "x($wc+4).''."\n"; # + $allstring .= " "x($wc+4).''."\n"; # + $allstring .= " "x($wc+4).''."\n"; # + $allstring .= " "x($wc+2).''."\n"; # + $allstring .= " "x$wc.''."\n"; + $allstring .= " "x$wc.''."\n"; + } + + # close up the graph + $allstring .= ' '."\n"; + $allstring .= ''."\n"; + + # TODO: HANDLE + # defined $node->{'embed'} + # see line 942 + + return $allstring; +} + +sub printGraphMLNode +{ + my $wc = $_[0]; + my $pnode = $_[1]; + my $gmlgraph = $_[2]; + my @nodes = @{$gmlgraph->{'Nodes'}}; + my @edges = @{$gmlgraph->{'Edges'}}; + + # we need to determine if this is a group node + my @cnodes = grep { $_->{'gid'} eq $pnode->{"ID"} } @nodes; + # Add node info + # # set defaults + if (!defined $pnode->{'fill'}) { $pnode->{'fill'} = "#CCCCFF" }; + if (!defined $pnode->{'outline'}) { $pnode->{'outline'} = "#000000" }; + if (!defined $pnode->{'hasOutline'}) { $pnode->{'hasOutline'} = "0" }; + if (!defined $pnode->{'outlineStyle'}) { $pnode->{'outlineStyle'} = "line" }; + if (!defined $pnode->{'outlineWidth'}) { $pnode->{'outlineWidth'} = "1" }; + if (!defined $pnode->{'type'}) { $pnode->{'type'} = "roundrectangle" }; + if (!defined $pnode->{'anchor'}) { $pnode->{'anchor'} = "c" }; + if (!defined $pnode->{'fontName'}) { $pnode->{'fontName'} = "Dialog" }; + if (!defined $pnode->{'fontSize'}) { $pnode->{'fontSize'} = "12" }; + if (!defined $pnode->{'fontStyle'}) { $pnode->{'fontStyle'} = "plain" }; + if (!defined $pnode->{'text'}) { $pnode->{'text'} = $pnode->{"label"} }; + + my $nodestr = " "x$wc.' 0) { + # we are a group node + # Start node + $nodestr .= '" yfiles.foldertype="group">'."\n"; + $nodestr .= " "x$wcn.''."\n"; # + $nodestr .= " "x($wcn+2).''."\n"; # + $nodestr .= " "x($wcn+4).''."\n"; # + $nodestr .= " "x($wcn+6).''."\n"; # + $nodestr .= " "x($wcn+8).''."\n"; # + if ($pnode->{'hasOutline'}) { + $nodestr .= " "x($wcn+8).''."\n"; # + } + $nodestr .= " "x($wcn+8).''."\n"; # + $nodestr .= " "x($wcn+8).'{'fontName'}.'" fontSize="'.$pnode->{'fontSize'}.'" '; + $nodestr .= 'fontStyle="'.$pnode->{'fontStyle'}.'" hasBackgroundColor="false" '; + $nodestr .= 'hasLineColor="false" horizontalTextPosition="center" iconTextGap="4" '; + $nodestr .= 'modelName="internal" modelPosition="t" textColor="#000000" '; + $nodestr .= 'verticalTextPosition="bottom" visible="true">'.$pnode->{'text'}.''."\n"; + $nodestr .= " "x($wcn+6).''."\n"; # + $nodestr .= " "x($wcn+4).''."\n"; # + $nodestr .= " "x($wcn+2).''."\n"; # + $nodestr .= " "x$wcn.''."\n"; # + } else { + # we are a shape node + $nodestr .= '">'."\n"; + $nodestr .= " "x$wcn.''."\n"; # + $nodestr .= " "x($wcn+2).''."\n"; # + $nodestr .= " "x($wcn+4).''."\n"; # + if ($pnode->{'hasOutline'}) { + $nodestr .= " "x($wcn+4).''."\n"; # + } + $nodestr .= " "x($wcn+4).''."\n"; # + $nodestr .= " "x($wcn+4).'{'fontName'}.'" fontSize="'.$pnode->{'fontSize'}.'" '; + $nodestr .= 'fontStyle="'.$pnode->{'fontStyle'}.'" hasBackgroundColor="false" '; + $nodestr .= 'hasLineColor="false" horizontalTextPosition="center" iconTextGap="4" '; + $nodestr .= 'modelName="internal" modelPosition="t" textColor="#000000" '; + $nodestr .= 'verticalTextPosition="bottom" visible="true">'.$pnode->{'text'}.''."\n"; + $nodestr .= " "x($wcn+2).''."\n"; # + $nodestr .= " "x$wcn.''."\n"; # + } + + # if we have children, write those now + my $nctr = 0; + if (scalar @cnodes > 0) { + $nodestr .= " "x$wcn.''."\n"; + foreach my $cnode(@cnodes) + { + $cnode->{'hierID'} = $pnode->{"hierID"}."::n$nctr"; + $nctr += 1; + $nodestr .= printGraphMLNode($wcn+2, $cnode, $gmlgraph); + } + $nodestr .= " "x$wcn.''."\n"; + } + # done with parent node + $nodestr .= " "x$wc.''."\n"; + return $nodestr; +} +#### GraphML 1 END ##### + +#### GraphML 2 START ##### +sub printGraphML2 +{ + my $gmlgraph = shift @_; + my @nodes = @{$gmlgraph->{'Nodes'}}; + my @edges = @{$gmlgraph->{'Edges'}}; + + # start with header and graph + my $allstring = ''."\n"; + $allstring .= '{'gid'} eq '' } @nodes; + my $nctr = 0; + foreach my $pnode(@pnodes) + { + $pnode->{'hierID'} = "n$nctr"; + $nctr += 1; + $allstring .= printGraphMLNode2($wc, $pnode, $gmlgraph); + } + + # # Now each edge... + my %edge_id_map = (); + my $edgeid = ''; + my $resolved_source = ''; + my $resolved_target = ''; + my @source = (); + my @target = (); + foreach my $edge(@edges) + { + @source = grep { $_->{'ID'} eq $edge->{'source'} } @nodes; + @target = grep { $_->{'ID'} eq $edge->{'target'} } @nodes; + $resolved_source = $source[0]->{'hierID'}; + $resolved_target = $target[0]->{'hierID'}; + + if (not (defined $edge_id_map{$source[0]->{'ID'}}) ) { $edge_id_map{$source[0]->{'ID'}} = 0}; + + $allstring .= " "x$wc.'{'ID'}} += 1; + $allstring .= 'source="'.$resolved_source.'" '; + $allstring .= 'target="'.$resolved_target.'">'."\n"; + # add data + my $graphics = $edge->{'graphics'}; + $allstring .= " "x$wc.''."\n"; # + $allstring .= " "x($wc+2).''."\n"; # + $allstring .= " "x($wc+4).''."\n"; # + $allstring .= " "x($wc+4).''."\n"; # + $allstring .= " "x($wc+4).''."\n"; # + $allstring .= " "x($wc+2).''."\n"; # + $allstring .= " "x$wc.''."\n"; # + $allstring .= " "x$wc.''."\n"; + } + + # close up the graph + $allstring .= ' '."\n"; + $allstring .= ''."\n"; + return $allstring; +} + +sub printGraphMLNode2 +{ + my $wc = $_[0]; + my $pnode = $_[1]; + my $gmlgraph = $_[2]; + my @nodes = @{$gmlgraph->{'Nodes'}}; + my @edges = @{$gmlgraph->{'Edges'}}; + + # we need to determine if this is a group node + my @cnodes = grep { $_->{'gid'} eq $pnode->{"ID"} } @nodes; + # Add node info + my $graphics = $pnode->{'graphics'}; + my $labelgraphics = $pnode->{'LabelGraphics'}; + my $nodestr = " "x$wc.' 0) { + # we are a group node + # Start node + $nodestr .= '" yfiles.foldertype="group">'."\n"; + $nodestr .= " "x$wcn.''."\n"; # + $nodestr .= " "x($wcn+2).''."\n"; # + $nodestr .= " "x($wcn+4).''."\n"; # + $nodestr .= " "x($wcn+6).''."\n"; # + $nodestr .= " "x($wcn+8).''."\n"; # + if ($graphics->{'hasOutline'}) { + $nodestr .= " "x($wcn+8).''."\n"; # + } + $nodestr .= " "x($wcn+8).''."\n"; # + $nodestr .= " "x($wcn+8).'{'fontName'}.'" fontSize="'.$labelgraphics->{'fontSize'}.'" '; + $nodestr .= 'fontStyle="'.$labelgraphics->{'fontStyle'}.'" hasBackgroundColor="false" '; + $nodestr .= 'hasLineColor="false" horizontalTextPosition="center" iconTextGap="4" '; + $nodestr .= 'modelName="internal" modelPosition="t" textColor="#000000" '; + $nodestr .= 'verticalTextPosition="bottom" visible="true">'.$labelgraphics->{'text'}.''."\n"; + $nodestr .= " "x($wcn+6).''."\n"; # + $nodestr .= " "x($wcn+4).''."\n"; # + $nodestr .= " "x($wcn+2).''."\n"; # + $nodestr .= " "x$wcn.''."\n"; # + } else { + # we are a shape node + $nodestr .= '">'."\n"; + $nodestr .= " "x$wcn.''."\n"; # + $nodestr .= " "x($wcn+2).''."\n"; # + $nodestr .= " "x($wcn+4).''."\n"; # + if ($graphics->{'hasOutline'}) { + $nodestr .= " "x($wcn+4).''."\n"; # + } + $nodestr .= " "x($wcn+4).''."\n"; # + $nodestr .= " "x($wcn+4).'{'fontName'}.'" fontSize="'.$labelgraphics->{'fontSize'}.'" '; + $nodestr .= 'fontStyle="'.$labelgraphics->{'fontStyle'}.'" hasBackgroundColor="false" '; + $nodestr .= 'hasLineColor="false" horizontalTextPosition="center" iconTextGap="4" '; + $nodestr .= 'modelName="internal" modelPosition="t" textColor="#000000" '; + $nodestr .= 'verticalTextPosition="bottom" visible="true">'.$labelgraphics->{'text'}.''."\n"; + $nodestr .= " "x($wcn+2).''."\n"; # + $nodestr .= " "x$wcn.''."\n"; # + } + + # if we have children, write those now + my $nctr = 0; + if (scalar @cnodes > 0) { + $nodestr .= " "x$wcn.''."\n"; + foreach my $cnode(@cnodes) + { + $cnode->{'hierID'} = $pnode->{"hierID"}."::n$nctr"; + $nctr += 1; + $nodestr .= printGraphMLNode2($wcn+2, $cnode, $gmlgraph); + } + $nodestr .= " "x$wcn.''."\n"; + } + # done with parent node + $nodestr .= " "x$wc.''."\n"; + return $nodestr; +} +#### GraphML 2 END ##### + +sub printGML +{ + my $gmlgraph = shift @_; + my @nodes = @{$gmlgraph->{'Nodes'}}; + my @edges = @{$gmlgraph->{'Edges'}}; + + my @nodestrings = (); + my @edgestrings = (); + + my $q1 = " \""; + my $q2 = "\" "; + foreach my $node(@nodes) + { + my $string1= ""; + # graphics + $string1 .= "type".$q1.$node->{'type'}.$q2; + $string1 .= "fill".$q1.$node->{'fill'}.$q2; + if ($node->{'hasOutline'}==0) { $string1 .= "hasOutline 0 ";} + if (defined $node->{'outline'}) + { $string1 .= "outline".$q1.$node->{'outline'}.$q2;} + if ($node->{'outlineStyle'}) + {$string1 .= "outlineStyle".$q1.$node->{'outlineStyle'}.$q2;} + #if ($node->{'closed'}) + # {$string1 .= "closed 1";} + $string1 = "graphics [ ".$string1." ]"; + + # labelgraphics + my $string2 = ""; + $string2 .= "text".$q1.$node->{'label'}.$q2; + #$string2 .= "fill".$q1."#FFFFFF".$q2; + $string2 .= "anchor".$q1.$node->{'anchor'}.$q2; + if ($node->{'fontStyle'}) + {$string2 .= "fontStyle".$q1.$node->{'fontStyle'}.$q2;} + $string2 = "LabelGraphics [ ".$string2." ]"; + + my $string = ""; + $string .= "id ".$node->{'ID'}." "; + $string .= "label".$q1.$node->{'label'}.$q2; + if ($node->{'isGroup'}) + {$string .= "isGroup ".$node->{'isGroup'}." ";} + if (defined $node->{'gid'} and length($node->{'gid'}) > 0) + {$string .= "gid ".$node->{'gid'}." ";} + + my $string3 = ''; + if(defined $node->{'embed'}) + { + my $somegraph = $node->{'embed'}; + my $type = ref $somegraph; + if($type eq 'StructureGraph') + { + if($somegraph->{'Type'} eq 'Rule') + {$string3 = toGML_rule_operation($somegraph);} + else + {$string3 = toGML_pattern($somegraph);} + } + elsif($type eq 'NetworkGraph') + { $string3 = toGML_rule_network($somegraph);} + } + + my $str = join(" ",($string,$string1,$string2,$string3)); + my $str2= "node [\n".$str."\n ]"; + #$string = "node [".$string." ".$string1." ".$string2." ".$string2" ]"; + + push @nodestrings, $str2; + } + foreach my $edge(@edges) + { + my $string = ""; + my $string2 = ""; + $string2 .= "fill".$q1.$edge->{'fill'}.$q2; + my @temp = (0,1); + if ($edge->{'sourceArrow'} and $edge->{'targetArrow'}) + { + $string2 .= "arrow \"both\" "; + } + elsif($edge->{'sourceArrow'}) + { + $string2 .= "arrow \"first\" "; + } + elsif($edge->{'targetArrow'}) + { + $string2 .= "arrow \"last\" "; + } + if ($edge->{'sourceArrow'}) + { + if(!has(\@temp,$edge->{'sourceArrow'})) + { + $string2 .= "sourceArrow".$q1.$edge->{'sourceArrow'}.$q2; + } + } + if ($edge->{'targetArrow'}) + { + if(!has(\@temp,$edge->{'targetArrow'})) + { + $string2 .= "targetArrow".$q1.$edge->{'targetArrow'}.$q2; + } + } + if (defined $edge->{'width'}) + { + $string2 .= "width ".$edge->{'width'}." "; + } + + #my $string3 = ""; + if(defined $edge->{'arrowhead'}) + { + if ($edge->{'arrowhead'} eq 'inhibition' and $edge->{'targetArrow'}) + { + $string2 .= "targetArrow \"crows_foot_one\""; + } + if ($edge->{'arrowhead'} eq 'inhibition' and $edge->{'sourceArrow'}) + { + $string2 .= "sourceArrow \"crows_foot_one\""; + } + } + + $string2 = "graphics [ ".$string2." ]"; + $string .= "source ".$edge->{'source'}." "; + $string .= "target ".$edge->{'target'}." "; + + $string = "edge [ ".$string." ".$string2." ]"; + + push @edgestrings,$string; + } + + my $string = "graph\n[\n directed 1\n"; + $string .= join("\n",@nodestrings)."\n"; + $string .= join("\n",@edgestrings)."\n"; + $string .= "]\n"; + return $string; +} + +# toGML methods +sub toGML_rule_operation +{ + my $sg = shift @_; #imports a combined rule structure graph + # AS2021 - adding output types + my $outType = @_ ? shift @_: "graphml"; # the output type + + #this is a structure graph. + # could be pattern or a rule or combination of rules + my $type = $sg->{'Type'}; + my @nodelist = @{$sg->{'NodeList'}}; + + # remap all the ids to integers + my @idlist = map {$_->{'ID'}} @nodelist; + my %indhash = indexHash(\@idlist); + foreach my $node(@nodelist) { remapNode($node,\%indhash); } + + my @structnodes = grep ( { $_->{'Type'} ne 'BondState' and $_->{'Type'} ne 'GraphOp'} @nodelist); + my @gmlnodes = (); + + # old gml nodes + foreach my $node(@nodelist) + { + my $id = $node->{'ID'}; + my $name = $node->{'Name'}; + my $type = $node->{'Type'}; + + # ignore if it is a bond with two parents + if ( $type eq 'BondState' and scalar @{$node->{'Parents'}} == 2) + { next; } + + my $gmlnode = initializeGMLNode($id,$name,$node); + my $isstruct = 1; + # treat rules + if ($type eq 'Rule') { $gmlnode->{'isGroup'} = 1; $isstruct = 0;} + # treat graph ops + if ($type eq 'GraphOp') + { + if ($name eq 'ChangeState') + { + my @parents = @{$node->{'Parents'}}; + my $parent = findNode(\@nodelist,$parents[0]); + my @grandparents = @{$parent->{'Parents'}}; + my $grandparent = $grandparents[0]; + $gmlnode->{'gid'} = $grandparents[0]; + } + else + { $gmlnode->{'gid'} = $node->{'Rule'}; } + $isstruct = 0; + } + # treat wildcard bonds + if ($type eq 'BondState') + { + $gmlnode->{'gid'} = $node->{'Rule'}; + $isstruct = 0; + } + + # remaining nodes are structural and nonbonds + if ($isstruct) + { + if ($node->{'Parents'}) + { + foreach my $parent_id(@{$node->{'Parents'}}) + { + $gmlnode->{'gid'} = $parent_id; + } + } + else + { + $gmlnode->{'gid'} = $node->{'Rule'}; + } + if (hasChildren(\@structnodes,$node)) + { + $gmlnode->{'isGroup'} = 1; + } + } + push @gmlnodes, $gmlnode; + } + + my @bondnodes = grep ( { $_->{'Type'} eq 'BondState' } @nodelist); + my @gmledges = (); + # make edges for bonds + foreach my $node (@bondnodes) + { + my @parents = @{$node->{'Parents'}}; + my $source; + my $target; + # address wildcards + if (scalar @parents == 1) + { + $source = $node->{'ID'}; + $target = $parents[0]; + } + # ignore bonds that are made or removed + elsif ($node->{'Side'} eq 'both') + { + $source = $parents[0]; + $target = $parents[1]; + } + else {next;} + my $gmledge = initializeGMLEdge($source,$target); + push @gmledges,$gmledge; + } + + # make edges for edges adjacent to graph operation nodes + my @graphopnodes = grep ( { $_->{'Type'} eq 'GraphOp'} @nodelist); + foreach my $node (@graphopnodes) + { + my $name = $node->{'Name'}; + my $id = $node->{'ID'}; + my @parents = @{$node->{'Parents'}}; + my @c; + my @p; + my @consumed; + my @produced; + + if ($name eq 'ChangeState') + { + my @compstates = grep ( { $_->{'Type'} eq 'CompState' } @nodelist); + my @nodes = findNodes(\@compstates,\@parents); + @c = grep ( { $_->{'Side'} eq 'left' } @nodes); + @p = grep ( { $_->{'Side'} eq 'right' } @nodes); + } + + if ($name eq 'AddMol' or $name eq 'DeleteMol') + { + my @mols = grep ( { $_->{'Type'} eq 'Mol' } @nodelist); + my @nodes = findNodes(\@mols,\@parents); + @c = grep ( { $_->{'Side'} eq 'left' } @nodes); + @p = grep ( { $_->{'Side'} eq 'right' } @nodes); + } + + if ($name eq 'AddBond' or $name eq 'DeleteBond') + { + my @allbonds = grep ( { $_->{'Type'} eq 'BondState' } @nodelist); + my $bond = findNode(\@allbonds,$parents[0]); + my @comps = grep ( { $_->{'Type'} eq 'Comp' } @nodelist); + my @nodes = findNodes(\@comps, $bond->{'Parents'}); + if ($name eq 'DeleteBond') { @c = @nodes; } + if ($name eq 'AddBond') { @p = @nodes; } + } + + if (@c) { @consumed = map ($_->{'ID'},@c); } + if (@p) { @produced = map ($_->{'ID'},@p); } + + foreach my $id2(@consumed) + { + my $gmledge = initializeGMLEdge($id2,$id,1); + push @gmledges,$gmledge; + } + + foreach my $id2(@produced) + { + my $gmledge = initializeGMLEdge($id,$id2,1); + push @gmledges,$gmledge; + } + } + + # styling + my %stylemap = ('Rule'=>1,'Pattern'=>1, 'Mol'=>2, 'Comp'=>3, + 'BondState'=>3, 'CompState'=>4, 'GraphOp'=>5 ); + + foreach my $node(@gmlnodes) + { + my $object = $node->{'object'}; + my $type = $object->{'Type'}; + styleNode($node,$stylemap{$type}); + } + + foreach my $edge(@gmledges) + { + styleEdge($edge); + } + + # new gml nodes v2 + my @gmlnodes2 = (); + foreach my $node(@nodelist) + { + my $id = $node->{'ID'}; + my $name = $node->{'Name'}; + my $type = $node->{'Type'}; + + # ignore if it is a bond with two parents + if ( $type eq 'BondState' and scalar @{$node->{'Parents'}} == 2) + { next; } + + my $gmlnode = newnode($id,$name,$node); + my $isstruct = 1; + # treat rules + if ($type eq 'Rule') { $gmlnode->{'isGroup'} = 1; $isstruct = 0;} + # treat graph ops + if ($type eq 'GraphOp') + { + if ($name eq 'ChangeState') + { + my @parents = @{$node->{'Parents'}}; + my $parent = findNode(\@nodelist,$parents[0]); + my @grandparents = @{$parent->{'Parents'}}; + my $grandparent = $grandparents[0]; + $gmlnode->{'gid'} = $grandparents[0]; + } + else + { $gmlnode->{'gid'} = $node->{'Rule'}; } + $isstruct = 0; + } + # treat wildcard bonds + if ($type eq 'BondState') + { + $gmlnode->{'gid'} = $node->{'Rule'}; + $isstruct = 0; + } + + # remaining nodes are structural and nonbonds + if ($isstruct) + { + if ($node->{'Parents'}) + { + foreach my $parent_id(@{$node->{'Parents'}}) + { + $gmlnode->{'gid'} = $parent_id; + } + } + else + { + $gmlnode->{'gid'} = $node->{'Rule'}; + } + if (hasChildren(\@structnodes,$node)) + { + $gmlnode->{'isGroup'} = 1; + } + } + my $stylenodetype = ($type eq 'BondState') ? 'Comp' : $type; + style_node_rule_operation($gmlnode,$stylenodetype); + push @gmlnodes2, $gmlnode; + } + # @gmlnodes = @gmlnodes2; + # new gml edges + my @gmledges2 = (); + foreach my $node (@bondnodes) + { + my @parents = @{$node->{'Parents'}}; + my $source; + my $target; + # address wildcards + if (scalar @parents == 1) + { + $source = $node->{'ID'}; + $target = $parents[0]; + } + # ignore bonds that are made or removed + elsif ($node->{'Side'} eq 'both') + { + $source = $parents[0]; + $target = $parents[1]; + } + else {next;} + my $gmledge = newedge($source,$target,0,0,''); + style_edge_rule_operation($gmledge,'Bond'); + push @gmledges2,$gmledge; + } + + foreach my $node (@graphopnodes) + { + my $name = $node->{'Name'}; + my $id = $node->{'ID'}; + my @parents = @{$node->{'Parents'}}; + my @c; + my @p; + my @consumed; + my @produced; + + if ($name eq 'ChangeState') + { + my @compstates = grep ( { $_->{'Type'} eq 'CompState' } @nodelist); + my @nodes = findNodes(\@compstates,\@parents); + @c = grep ( { $_->{'Side'} eq 'left' } @nodes); + @p = grep ( { $_->{'Side'} eq 'right' } @nodes); + } + + if ($name eq 'AddMol' or $name eq 'DeleteMol') + { + my @mols = grep ( { $_->{'Type'} eq 'Mol' } @nodelist); + my @nodes = findNodes(\@mols,\@parents); + @c = grep ( { $_->{'Side'} eq 'left' } @nodes); + @p = grep ( { $_->{'Side'} eq 'right' } @nodes); + } + + if ($name eq 'AddBond' or $name eq 'DeleteBond') + { + my @allbonds = grep ( { $_->{'Type'} eq 'BondState' } @nodelist); + my $bond = findNode(\@allbonds,$parents[0]); + my @comps = grep ( { $_->{'Type'} eq 'Comp' } @nodelist); + my @nodes = findNodes(\@comps, $bond->{'Parents'}); + if ($name eq 'DeleteBond') { @c = @nodes; } + if ($name eq 'AddBond') { @p = @nodes; } + } + + if (@c) { @consumed = map ($_->{'ID'},@c); } + if (@p) { @produced = map ($_->{'ID'},@p); } + + foreach my $id2(@consumed) + { + my $gmledge = newedge($id2,$id,1,0,''); + style_edge_rule_operation($gmledge,'Reactant'); + push @gmledges2,$gmledge; + } + + foreach my $id2(@produced) + { + my $gmledge = newedge($id,$id2,1,0,''); + style_edge_rule_operation($gmledge,'Product'); + push @gmledges2,$gmledge; + } + } + @gmlnodes = @gmlnodes2; + @gmledges = @gmledges2; + + my $gmlgraph = GMLGraph->new(); + $gmlgraph->{'Nodes'} = \@gmlnodes; + $gmlgraph->{'Edges'} =\@gmledges; + + if ($outType eq "gml") { + return printGML2($gmlgraph); + } else { + return printGraphML2($gmlgraph); + } +} + +sub toGML_pattern +{ + my $sg = shift @_; #imports a rule pattern graph + # AS2021 - adding output types + my $outType = @_ ? shift @_: "graphml"; # the output type + my @nodelist = @{$sg->{'NodeList'}}; + #remap all ids to integers + my @idlist = map{$_->{'ID'}} @nodelist; + my %indhash = indexHash(\@idlist); + foreach my $node(@nodelist) { remapNode($node,\%indhash); } + my @structnodes = grep ( + { $_->{'Type'} ne 'BondState' + and $_->{'Type'} ne 'Rule' + and $_->{'Type'} ne 'Pattern'} @nodelist); + #print scalar @nodelist; print "\n"; + #print scalar @structnodes; print "\n"; + + my @gmlnodes = (); + foreach my $node(@nodelist) + { + my $id = $node->{'ID'}; + my $name = $node->{'Name'}; + my $type = $node->{'Type'}; + + # ignore if it is a bond with two parents + if ( $type eq 'BondState' and scalar @{$node->{'Parents'}} == 2) + { next; } + + my $gmlnode = initializeGMLNode($id,$name,$node); + my $isstruct = 1; + + # treat wildcard bonds + if ($type eq 'BondState') + { + my @comps = @{$node->{'Parents'}}; + my $comp = findNode(\@nodelist,$comps[0]); + my @mols = @{$comp->{'Parents'}}; + my $mol = findNode(\@nodelist,$mols[0]); + if(defined $mol->{'Parents'}) + { + my @sp = @{$mol->{'Parents'}}; + $gmlnode->{'gid'} = $sp[0]; + } + $isstruct = 0; + } + if ($isstruct) + { + if ($node->{'Parents'}) + { + foreach my $parent_id(@{$node->{'Parents'}}) + { + $gmlnode->{'gid'} = $parent_id; + } + } + if (hasChildren(\@structnodes,$node)) + { + $gmlnode->{'isGroup'} = 1; + } + } + push @gmlnodes, $gmlnode; + } + + my @gmledges = (); + # draw the bonds + my @bondnodes = grep ( { $_->{'Type'} eq 'BondState' } @nodelist); + foreach my $node(@bondnodes) + { + my @parents = @{$node->{'Parents'}}; + my $source; + my $target; + if (scalar @parents == 1) + { + $source = $node->{'ID'}; + $target = $parents[0]; + } + else + { + $source = $parents[0]; + $target = $parents[1]; + } + my $gmledge = initializeGMLEdge($source,$target); + push @gmledges,$gmledge; + + } + # draw edges to rules + + + my %stylemap = ('Rule'=>5,'Pattern'=>1, 'Mol'=>2, 'Comp'=>3, + 'BondState'=>3, 'CompState'=>4 ); + foreach my $node(@gmlnodes) + { + my $object = $node->{'object'}; + my $type = $object->{'Type'}; + styleNode($node,$stylemap{$type}); + } + + foreach my $edge(@gmledges) + { + styleEdge($edge); + } + + my $gmlgraph = GMLGraph->new(); + $gmlgraph->{'Nodes'} = \@gmlnodes; + $gmlgraph->{'Edges'} =\@gmledges; + if ($outType eq "gml") { + return printGML($gmlgraph); + } else { + return printGraphML($gmlgraph); + } +} + +sub toGML_rule_pattern +{ + my $sg = shift @_; #imports a rule pattern graph + # AS2021 - adding output types + my $outType = @_ ? shift @_: "graphml"; # the output type + + my @nodelist = @{$sg->{'NodeList'}}; + #remap all ids to integers + my @idlist = map{$_->{'ID'}} @nodelist; + my %indhash = indexHash(\@idlist); + foreach my $node(@nodelist) { remapNode($node,\%indhash); } + my @structnodes = grep ( + { $_->{'Type'} ne 'BondState' + and $_->{'Type'} ne 'Rule' + and $_->{'Type'} ne 'Pattern'} @nodelist); + #print scalar @nodelist; print "\n"; + #print scalar @structnodes; print "\n"; + + # old gml nodes and edges + my @gmlnodes = (); + foreach my $node(@nodelist) + { + my $id = $node->{'ID'}; + my $name = $node->{'Name'}; + my $type = $node->{'Type'}; + + # ignore if it is a bond with two parents + if ( $type eq 'BondState' and scalar @{$node->{'Parents'}} == 2) + { next; } + + my $gmlnode = initializeGMLNode($id,$name,$node); + my $isstruct = 1; + + # treat patterns + if ($type eq 'Pattern') + { + $gmlnode->{'isGroup'} = 1; + $gmlnode->{'label'} = ''; + #$gmlnode->{'gid'} = $node->{'Rule'}; + $isstruct = 0; + } + + # treat wildcard bonds + if ($type eq 'BondState') + { + my @comps = @{$node->{'Parents'}}; + my $comp = findNode(\@nodelist,$comps[0]); + my @mols = @{$comp->{'Parents'}}; + my $mol = findNode(\@nodelist,$mols[0]); + my @sp = @{$mol->{'Parents'}}; + $gmlnode->{'gid'} = $sp[0]; + $isstruct = 0; + } + if ($isstruct) + { + if ($node->{'Parents'}) + { + foreach my $parent_id(@{$node->{'Parents'}}) + { + $gmlnode->{'gid'} = $parent_id; + } + } + if (hasChildren(\@structnodes,$node)) + { + $gmlnode->{'isGroup'} = 1; + } + } + push @gmlnodes, $gmlnode; + } + my @gmledges = (); + # draw the bonds + my @bondnodes = grep ( { $_->{'Type'} eq 'BondState' } @nodelist); + foreach my $node(@bondnodes) + { + my @parents = @{$node->{'Parents'}}; + my $source; + my $target; + if (scalar @parents == 1) + { + $source = $node->{'ID'}; + $target = $parents[0]; + } + else + { + $source = $parents[0]; + $target = $parents[1]; + } + my $gmledge = initializeGMLEdge($source,$target); + push @gmledges,$gmledge; + + } + # draw edges to rules + + my @rulenodes = grep ( { $_->{'Type'} eq 'Rule' } @nodelist); + my @patterns = grep ( { $_->{'Type'} eq 'Pattern' } @nodelist); + foreach my $rule(@rulenodes) + { + #find the participating species + my $id = $rule->{'ID'}; + my @participating = grep ( { $_->{'Rule'} eq $id } @patterns); + my @reac = grep ( { index($_->{'Name'},'R')==0 } @participating); + my @prod = grep ( { index($_->{'Name'},'P')==0} @participating); + my $targetarrow = 1; + my $sourcearrow = $rule->{'Reversible'} ? 1 : 0; + foreach my $patt(@reac) + { + my $source = $patt->{'ID'}; + my $target = $id; + my $gmledge = initializeGMLEdge($source,$target,$targetarrow,$sourcearrow); + push @gmledges,$gmledge; + } + foreach my $patt(@prod) + { + my $source = $id; + my $target = $patt->{'ID'}; + my $gmledge = initializeGMLEdge($source,$target,$targetarrow,$sourcearrow); + push @gmledges,$gmledge; + } + } + + my %stylemap = ('Rule'=>5,'Pattern'=>1, 'Mol'=>2, 'Comp'=>3, + 'BondState'=>3, 'CompState'=>4 ); + foreach my $node(@gmlnodes) + { + my $object = $node->{'object'}; + my $type = $object->{'Type'}; + styleNode($node,$stylemap{$type}); + } + + foreach my $edge(@gmledges) + { + styleEdge($edge); + } + + # new gml rules and edges + my @gmlnodes2 = (); + foreach my $node(@nodelist) + { + my $id = $node->{'ID'}; + my $name = $node->{'Name'}; + my $type = $node->{'Type'}; + + # ignore if it is a bond with two parents + if ( $type eq 'BondState' and scalar @{$node->{'Parents'}} == 2) + { next; } + $name = '' if ($type eq 'Pattern'); + my $gmlnode = newnode($id,$name,$node); + my $isstruct = 1; + + # treat patterns + if ($type eq 'Pattern') + { + $gmlnode->{'isGroup'} = 1; + #$gmlnode->{'label'} = ''; + #$gmlnode->{'graphics'}->{'text'} = ''; + #$gmlnode->{'gid'} = $node->{'Rule'}; + $isstruct = 0; + } + + # treat wildcard bonds + if ($type eq 'BondState') + { + my @comps = @{$node->{'Parents'}}; + my $comp = findNode(\@nodelist,$comps[0]); + my @mols = @{$comp->{'Parents'}}; + my $mol = findNode(\@nodelist,$mols[0]); + my @sp = @{$mol->{'Parents'}}; + $gmlnode->{'gid'} = $sp[0]; + $isstruct = 0; + } + if ($isstruct) + { + if ($node->{'Parents'}) + { + foreach my $parent_id(@{$node->{'Parents'}}) + { + $gmlnode->{'gid'} = $parent_id; + } + } + if (hasChildren(\@structnodes,$node)) + { + $gmlnode->{'isGroup'} = 1; + } + } + my $nodestyletype = ($type eq 'BondState') ? 'Comp' : $type; + style_node_rule_pattern($gmlnode,$nodestyletype); + push @gmlnodes2, $gmlnode; + } + my @gmledges2 = (); + # draw the bonds + @bondnodes = grep ( { $_->{'Type'} eq 'BondState' } @nodelist); + foreach my $node(@bondnodes) + { + my @parents = @{$node->{'Parents'}}; + my $source; + my $target; + if (scalar @parents == 1) + { + $source = $node->{'ID'}; + $target = $parents[0]; + } + else + { + $source = $parents[0]; + $target = $parents[1]; + } + my $gmledge = newedge($source,$target,0,0,''); + style_edge_rule_pattern($gmledge,'Bond'); + push @gmledges2,$gmledge; + + } + # draw edges to rules + + @rulenodes = grep ( { $_->{'Type'} eq 'Rule' } @nodelist); + @patterns = grep ( { $_->{'Type'} eq 'Pattern' } @nodelist); + foreach my $rule(@rulenodes) + { + #find the participating species + my $id = $rule->{'ID'}; + my @participating = grep ( { $_->{'Rule'} eq $id } @patterns); + my @reac = grep ( { index($_->{'Name'},'R')==0 } @participating); + my @prod = grep ( { index($_->{'Name'},'P')==0} @participating); + my $targetarrow = 1; + my $sourcearrow = $rule->{'Reversible'} ? 1 : 0; + foreach my $patt(@reac) + { + my $source = $patt->{'ID'}; + my $target = $id; + my $gmledge = newedge($source,$target,1,0,''); + style_edge_rule_pattern($gmledge,'Reactant'); + push @gmledges2,$gmledge; + } + foreach my $patt(@prod) + { + my $source = $id; + my $target = $patt->{'ID'}; + my $gmledge = newedge($source,$target,1,0,''); + style_edge_rule_pattern($gmledge,'Product'); + push @gmledges2,$gmledge; + } + } + @gmlnodes = @gmlnodes2; + @gmledges = @gmledges2; + + my $gmlgraph = GMLGraph->new(); + $gmlgraph->{'Nodes'} = \@gmlnodes; + $gmlgraph->{'Edges'} =\@gmledges; + if ($outType eq "gml") { + return printGML2($gmlgraph); + } else { + return printGraphML2($gmlgraph); + } +} + + +sub toGML_rule_network +{ + my $bpg = shift @_; + my $collapsed = $bpg->{'Collapsed'}; + my $grouped = defined $bpg->{'NodeClass'} ? 1 : 0; + my $embed = @_ ? shift @_ : 0; + my $ruleNames = @_ ? shift @_: 0; + # AS2021 - adding output types + my $outType = @_ ? shift @_: "graphml"; # the output type + + #my @groups = (); + #my @groups = @_ ? @{shift @_} : (); + #my $closed = @_ ? shift @_ : 0; + + my @nodelist = @{$bpg->{'NodeList'}}; + my @edgelist = @{$bpg->{'EdgeList'}}; + my %nodetype = %{$bpg->{'NodeType'}}; + + my @gmlnodes = (); + + # processing node classes + my %gidhash; + my %isgroup; + my @classnodes; + my @classed; + my %classes; + if (defined $bpg->{'NodeClass'}) + { + %classes = %{$bpg->{'NodeClass'}}; + @classnodes = uniq(values %classes); + push @nodelist, @classnodes; + @classed = uniq(keys %classes); + foreach my $item(@classed) + { + my $type = $nodetype{$item}; + my $grp = $classes{$item}; + $nodetype{$grp} = ($type eq 'Rule') ? 'RuleGroup' : 'PatternGroup'; + } + } + my %nodetypeorder = ( 'AtomicPattern' => 0, 'Rule' => 1, 'PatternGroup' => 2, 'RuleGroup' => 3); + my @nodelist2 = sort { $nodetypeorder{$nodetype{$a}} <=> $nodetypeorder{$nodetype{$b}} || $a cmp $b } @nodelist; + #print join "\n",@nodelist2;exit; + my %indhash = indexHash( [@nodelist2] ); + + # OLD gmlnode & gmledge + foreach my $node(@nodelist2) + { + my $id = $indhash{$node}; + my $name = (has(['Rule','RuleGroup'],$nodetype{$node}) and not $ruleNames) ? "": prettify($node); + #my $name = prettify($node); + my $gmlnode = initializeGMLNode($id,$name,$node); + $gmlnode->{'gid'} = $indhash{$classes{$node}} if (has(\@classed,$node)==1); + $gmlnode->{'isGroup'} = 1 if (has(\@classnodes,$node)==1); + styleNode2($gmlnode); + styleNode2($gmlnode,$nodetype{$node},'color'); + if((defined $collapsed and $collapsed == 1) or has(['Rule','AtomicPattern'],$nodetype{$node}) ) + { + styleNode2($gmlnode,$nodetype{$node},'shape'); + } + if($embed and ($nodetype{$node} eq 'AtomicPattern') and $node =~ /\(/) + { + $gmlnode->{'anchor'} = "t"; + my $psg = stringToPatternStructureGraph($node,0); + $gmlnode->{'embed'} = $psg; + } + push @gmlnodes, $gmlnode; + } + my @gmledges = (); + foreach my $edge( @edgelist ) + { + my @splits = split(":",$edge); + my $source = $indhash{$splits[0]}; + my $target = $indhash{$splits[1]}; + #print $source,",",$target,"\n"; + my $type = $splits[2]; + my $gmledge = initializeGMLEdge($source,$target,"","",$edge); + styleEdge2($gmledge,$type); + push @gmledges,$gmledge; + } + + # GMLv2 new nodegml and edgegml 5/22/2016 + my @gmlnodes2 = (); + foreach my $node(@nodelist2) + { + my $id = $indhash{$node}; + my $name = (has(['Rule','RuleGroup'],$nodetype{$node}) and not $ruleNames) ? "": prettify($node); + + my $gmlnode = newnode($id,$name,$node); + $gmlnode->{'gid'} = $indhash{$classes{$node}} if (has(\@classed,$node)==1); + $gmlnode->{'isGroup'} = 1 if (has(\@classnodes,$node)==1); + + my $graphtype = $collapsed ? 'Collapsed' : $grouped ? 'Grouped' : 'Normal'; + style_node_rule_network($gmlnode,$nodetype{$node},$graphtype); + push @gmlnodes2,$gmlnode; + } + @gmlnodes = @gmlnodes2; + my @gmledges2 = (); + foreach my $edge( @edgelist ) + { + my ($r,$p,$type) = split(":",$edge); + my $source; + my $target; + if( ($type eq "Reactant") or ($type eq "Context") ) + { + $source = $indhash{$p}; $target = $indhash{$r}; + } + else + { + $source = $indhash{$r}; $target = $indhash{$p}; + } + my $gmledge = newedge($source,$target,1,0,$edge); + + my $graphtype = $collapsed ? 'Collapsed' : $grouped ? 'Grouped' : 'Normal'; + style_edge_rule_network($gmledge,$type,$graphtype); + push @gmledges2,$gmledge; + } + @gmledges = @gmledges2; + + + + my $gmlgraph = GMLGraph->new(); + $gmlgraph->{'Nodes'} = \@gmlnodes; + $gmlgraph->{'Edges'} =\@gmledges; + #return printGML($gmlgraph); + if ($outType eq "gml") { + return printGML2($gmlgraph); + } else { + return printGraphML2($gmlgraph); + } +} + +sub toGML_rinf +{ + my $rinf = shift @_; + # AS2021 - adding output types + my $outType = @_ ? shift @_: "graphml"; # the output type + my @nodelist = @{$rinf->{'Nodes'}}; + my @edgelist = @{$rinf->{'Edges'}}; + my @gmlnodes2 = (); + my %indhash = indexHash( [@nodelist] ); + foreach my $node(@nodelist) + { + my $id = $indhash{$node}; + my $name = $node; + my $gmlnode = newnode($id,$name,$node); + style_node_rinf($gmlnode,'Rule'); + push @gmlnodes2,$gmlnode; + } + my @gmlnodes = @gmlnodes2; + my @gmledges2 = (); + foreach my $edge( @edgelist ) + { + my ($from,$to,$type) = split(":",$edge); + my $source = $indhash{$from}; + my $target = $indhash{$to}; + my $gmledge = newedge($source,$target,1,0,$edge); + style_edge_rinf($gmledge,$type); + push @gmledges2,$gmledge; + } + my @gmledges = @gmledges2; + + + + my $gmlgraph = GMLGraph->new(); + $gmlgraph->{'Nodes'} = \@gmlnodes; + $gmlgraph->{'Edges'} =\@gmledges; + #return printGML($gmlgraph); + if ($outType eq "gml") { + return printGML2($gmlgraph); + } else { + return printGraphML2($gmlgraph); + } + return ''; +} + +sub printGML2 +{ + my $gmlgraph = shift @_; + my @nodes = @{$gmlgraph->{'Nodes'}}; + my @edges = @{$gmlgraph->{'Edges'}}; + my @nodestrings = map { printnode($_) } @nodes; + my @edgestrings = map { printedge($_) } @edges; + + my $string = "graph\n[\n directed 1\n"; + $string .= join("\n",@nodestrings)."\n"; + $string .= join("\n",@edgestrings)."\n"; + $string .= "]\n"; + return $string; +} + +sub toGML_process +{ + my $pg = shift @_; + # AS2021 - adding output types + my $outType = @_ ? shift @_: "graphml"; # the output type + my $embed = (defined $pg->{'Embed'}); + + my %indhash = indexHash( $pg->{'Processes'} ); + + my @gmlnodes; + foreach my $r(@{$pg->{'Processes'}}) + { + my $id = $indhash{$r}; + my $name = $pg->{'Names'}->{$r}; + my $gmlnode = initializeGMLNode($id,$name,$r); + styleNode2($gmlnode); + if($embed) + { + $gmlnode->{'anchor'} = "t"; + $gmlnode->{'embed'} = $pg->{'Embed'}->{$r}; + } + push @gmlnodes,$gmlnode; + } + + my @gmledges; + foreach my $edge(@{$pg->{'Edges'}}) + { + my ($r1,$r2) = split(" ",$edge); + my $source = $indhash{$r1}; + my $target = $indhash{$r2}; + my $gmledge = initializeGMLEdge($source,$target,"","",$edge); + styleEdge2($gmledge,'Process'); + push @gmledges,$gmledge; + + } + + my $gmlgraph = GMLGraph->new(); + $gmlgraph->{'Nodes'} = \@gmlnodes; + $gmlgraph->{'Edges'} =\@gmledges; + return printGML($gmlgraph); +} + +sub toGML_process2 +{ + my $pg = shift @_; + # AS2021 - adding output types + my $outType = @_ ? shift @_: "graphml"; # the output type + my $embed = (defined $pg->{'Embed'}); + + #my %indhash = indexHash( $pg->{'Processes'} ); + + my @processes = @{$pg->{'Nodes'}}; + my @names = @{$pg->{'Names'}}; + my @gmlnodes; + foreach my $i(0..@processes-1) + { + #my $id = $i; + #my $name = $names[$i]; + my $name = @names ? $names[$i]: ''; + my $gmlnode = initializeGMLNode($i,$name,$processes[$i]); + styleNode2($gmlnode); + if($embed) + { + $gmlnode->{'anchor'} = "t"; + $gmlnode->{'embed'} = $pg->{'Embed'}->[$i]; + } + push @gmlnodes,$gmlnode; + } + + my @gmledges; + foreach my $edge(@{$pg->{'Edges'}}) + { + my ($i,$j) = split(" ",$edge); + my $source = $i; + my $target = $j; + my $gmledge = initializeGMLEdge($source,$target,"","",$edge); + styleEdge2($gmledge,'Process'); + push @gmledges,$gmledge; + + } + + my $gmlgraph = GMLGraph->new(); + $gmlgraph->{'Nodes'} = \@gmlnodes; + $gmlgraph->{'Edges'} =\@gmledges; + return printGML($gmlgraph); +} + +sub styleNode +{ + my $gmlnode = shift @_; + my $arg = @_ ? shift @_ : 0; + $gmlnode->{'hasOutline'} = 1; + # defaults + $gmlnode->{'type'} = "roundrectangle"; + $gmlnode->{'fill'} = "#FFFFFF"; + $gmlnode->{'outline'} = "#000000"; + if ($gmlnode->{'isGroup'}) {$gmlnode->{'anchor'} = "t";} + else {$gmlnode->{'anchor'} = "c";} + + # node, Rule, yED + if ($arg==1) { $gmlnode->{'outlineStyle'} = "dotted"; } + # node, Mol, yED + if ($arg==2) { $gmlnode->{'fontStyle'} = "bold"; $gmlnode->{'fill'} = "#D2D2D2"; } + # node, Comp/BondState, yED + if ($arg==3) { + #$gmlnode->{'fill'} = "#D2D2D2"; + $gmlnode->{'fill'} = "#FFFFFF"; } + # node, CompState, yED + if ($arg==4) { $gmlnode->{'fill'} = "#FFCC00"; } + # node, GraphOp, yED + if ($arg==5) + { + $gmlnode->{'fill'} = "#CC99FF"; + $gmlnode->{'type'} = 'hexagon'; + $gmlnode->{'fontStyle'} = 'italic'; + } + return; +} + +sub styleNode2 +{ + my $gmlnode = shift @_; + my $type = @_ ? shift @_ : undef; + my $property = @_ ? shift @_ : undef; + + my @props = qw(shape fill); + my @types =qw(Rule AtomicPattern RuleGroup PatternGroup); + my %keywords = ( 'shape'=>'type', 'color'=>'fill'); + + my %properties2 = + ( + 'Rule' => { 'shape' => 'hexagon', 'color' => '#bbb8f4' }, + 'AtomicPattern' => { 'shape' => 'roundrectangle', 'color' => '#fda7a9' }, + 'PatternGroup' => { 'shape' => 'roundrectangle', 'color' => '#fee4e5' }, + 'RuleGroup' => { 'shape' => 'hexagon', 'color' => '#eae9fb' }, + ); + + my %properties = + ( + 'Rule' => { 'shape' => 'hexagon', 'color' => '#bbb8f4' }, + 'AtomicPattern' => { 'shape' => 'roundrectangle', 'color' => '#f4bbb8' }, + 'PatternGroup' => { 'shape' => 'roundrectangle', 'color' => '#fee4e5' }, + 'RuleGroup' => { 'shape' => 'hexagon', 'color' => '#eae9fb' }, + ); + + if (defined $type and defined $property) + { + $gmlnode->{$keywords{$property}} = $properties{$type}->{$property}; + return; + } + + # defaults + $gmlnode->{'hasOutline'} = 1; + $gmlnode->{'type'} = "roundrectangle"; + $gmlnode->{'fill'} = "#FFFFFF"; + $gmlnode->{'outline'} = "#000000"; + if ($gmlnode->{'isGroup'}) {$gmlnode->{'anchor'} = "t";} + else {$gmlnode->{'anchor'} = "c";} + + return; +} + +sub styleEdge2 +{ + my $gmledge = shift @_; + my $type = @_ ? shift @_: undef; + my %properties = + ( + 'Reactant' => {'color'=>'#5e3c58','source'=>1,'target'=>0,'width'=>1,'arrowhead'=>'standard'}, + 'Product' => {'color'=>'#5e3c58','source'=>0,'target'=>1,'width'=>1,'arrowhead'=>'standard'}, + 'Wildcard' => {'color'=>'#5e3c58','source'=>1,'target'=>0,'width'=>1,'arrowhead'=>'standard'}, + 'Context' => {'color'=>'#798e87','source'=>1,'target'=>0,'width'=>1,'arrowhead'=>'standard'}, + 'Process' => {'color'=>'#000000','source'=>0,'target'=>1,'width'=>1,'arrowhead'=>'standard'}, + 'Inhibition' => {'color'=>'#5e3c58','source'=>0,'target'=>1,'width'=>1,'arrowhead'=>'inhibition'}, + ); + my %keywords = ('color'=>'fill','source'=>'sourceArrow','target'=>'targetArrow','width'=>'width','arrowhead'=>'arrowhead'); + + if(defined $type) + { + foreach my $prop(keys %keywords) + { + $gmledge->{$keywords{$prop}} = $properties{$type}->{$prop}; + } + } + + return; + +} + +sub styleEdge +{ + my $gmledge = shift @_; + my $arg = @_ ? shift @_ : 0 ; + # defaults + $gmledge->{'fill'} = "#000000"; + return; +} + + + +1; diff --git a/libvcell/vcell_install/bionetgen/Perl2/Visualization/NetworkGraph.pm b/libvcell/vcell_install/bionetgen/Perl2/Visualization/NetworkGraph.pm new file mode 100644 index 0000000..810e94c --- /dev/null +++ b/libvcell/vcell_install/bionetgen/Perl2/Visualization/NetworkGraph.pm @@ -0,0 +1,981 @@ +package Viz; +# pragmas +use strict; +use warnings; +no warnings 'redefine'; +# Perl Modules +use Class::Struct; +# BNG Modules +use Visualization::Viz; +use Visualization::StructureGraph; +use SpeciesGraph; + +struct NetworkGraph => +{ + 'NodeList' => '@', # array of strings + 'EdgeList' => '@', # array of strings + 'NodeType' => '%', # a hash indicating each node type + 'NodeClass' => '%', # a hash indicating equivalence class + 'Name' => '$', # a name which might come in handy to compare/combine rules + # of the form :: + # or ::Wildcard + 'Merged'=> 0, + 'Collapsed'=>0, + 'Filtered'=>0, + +}; +# is methods for checking +sub isWildcard{ return ($_[0] =~ /\!\+/) ? 1 : 0; } + +# basic make methods +sub makeAtomicPattern +{ + my @nodelist = @{shift @_}; + my $node = shift @_; + + my $type = $node->{'Type'}; + my $ap; + if ($type eq 'CompState') + { + my $comp = findNode(\@nodelist,${$node->{'Parents'}}[0]); + my $mol = findNode(\@nodelist,${$comp->{'Parents'}}[0]); + my $string = $mol->{'Name'}."(".$comp->{'Name'}."~".$node->{'Name'}.")"; + $ap = ($node->{'Name'} ne '?') ? $string : ""; + } + elsif ($type eq 'BondState') + { + my @comps = map (findNode(\@nodelist,$_), @{$node->{'Parents'}}) ; + my @mols = map (findNode(\@nodelist,${$_->{'Parents'}}[0]), @comps) ; + if (scalar @comps == 1) + { + # it's a wildcard + my $string = $mols[0]->{'Name'}."(".$comps[0]->{'Name'}."!".$node->{'Name'}.")"; + $ap = ($node->{'Name'} ne '?') ? $string : ""; + } + else + { + # it's a specified bond + my $string1 = $mols[0]->{'Name'}."(".$comps[0]->{'Name'}."!1)"; + my $string2 = $mols[1]->{'Name'}."(".$comps[1]->{'Name'}."!1)"; + $ap = join(".", sort {$a cmp $b} ($string1,$string2)); + } + } + elsif ($type eq 'Comp') + { + # return the unbound state + # is it really unbound? check it external to this method + my $mol = findNode(\@nodelist,${$node->{'Parents'}}[0]); + my $string = $mol->{'Name'}."(".$node->{'Name'}.")"; + $ap = $string; + } + elsif ($type eq 'Mol') + { + $ap = $node->{'Name'}; + } + return $ap; +} + +sub makeAtomicPatterns +{ + my $nodelist = shift @_; + my $nodes = shift @_; + my @aps = map { makeAtomicPattern($nodelist,$_)} @$nodes; + return @aps; +} + +sub makeTransformation +{ + my @nodelist = @{shift @_}; + my $node = shift @_; + my $type = $node->{'Type'}; + my $name = $node->{'Name'}; + my $arrow = "->"; + my $comma = ","; + my $tr; + if ($type ne 'GraphOp') { return undef; } + if ($name eq 'ChangeState') + { + my @comps = map (findNode(\@nodelist,$_), @{$node->{'Parents'}}); + my @left = grep( $_->{'Side'} eq 'left', @comps) ; + my @right = grep( $_->{'Side'} eq 'right', @comps) ; + my $leftstr = makeAtomicPattern(\@nodelist,$left[0]); + my $rightstr = makeAtomicPattern(\@nodelist,$right[0]); + $tr = $leftstr.$arrow.$rightstr; + } + elsif ($name eq 'AddBond') + { + my $bond = findNode(\@nodelist,${$node->{'Parents'}}[0]); + my @comps = map (findNode(\@nodelist,$_), @{$bond->{'Parents'}}); + my @leftstr = sort map ( makeAtomicPattern(\@nodelist,$_),@comps); + my $rightstr = makeAtomicPattern(\@nodelist,$bond); + $tr = join($comma,@leftstr).$arrow.$rightstr; + } + elsif ($name eq 'DeleteBond') + { + my $bond = findNode(\@nodelist,${$node->{'Parents'}}[0]); + # bond wildcards are also being deleted when molecules are deleted + # how do you transform them into processes? + # need to talk to bngdev + my @comps = map (findNode(\@nodelist,$_), @{$bond->{'Parents'}}); + if (scalar @comps == 1) { return ""; } + my @rightstr = sort map ( makeAtomicPattern(\@nodelist,$_),@comps); + my $leftstr = makeAtomicPattern(\@nodelist,$bond); + $tr = $leftstr.$arrow.join($comma,@rightstr); + } + elsif ($name eq 'AddMol') + { + my $mol = findNode(\@nodelist,${$node->{'Parents'}}[0]); + my $name = makeAtomicPattern(\@nodelist,$mol); + $tr = $arrow.$name; + } + elsif ($name eq 'DeleteMol') + { + # species deletion is interpreted as molecule deletion + # how to check? what to do? + my $mol = findNode(\@nodelist,${$node->{'Parents'}}[0]); + my $name = makeAtomicPattern(\@nodelist,$mol); + $tr = $name.$arrow; + } + return $tr; +} + +sub makeTransformationDeleteBond +{ + my @nodelist = @{shift @_}; + my $node = shift @_; + my $type = $node->{'Type'}; + my $name = $node->{'Name'}; + my $arrow = "->"; + my $comma = ","; + my $tr; + if ($name eq 'DeleteBond') + { + my $bond = findNode(\@nodelist,${$node->{'Parents'}}[0]); + return $tr if ($bond->{'Name'} eq '?'); + my @comps = grep {$_->{'Side'} eq 'both'} map (findNode(\@nodelist,$_), @{$bond->{'Parents'}}); + my @rightstr = sort map ( makeAtomicPattern(\@nodelist,$_),@comps); + my $leftstr = makeAtomicPattern(\@nodelist,$bond); + $tr = $leftstr.$arrow.join($comma,@rightstr); + } + return $tr; + +} + +sub makeEdge +{ + my %shortname = ( 'r'=>"Reactant", 'p'=>"Product", 'c'=>"Context", 's'=>"Syndel", 'w'=>"Wildcard", 'pp'=>"ProcessPair", 'co'=>"Cotransform", 'os'=>"Onsite" ); + + my $node1 = shift @_; + my $node2 = shift @_; + my $rel = $shortname{shift @_}; + + my $string = $node1.":".$node2.":".$rel; + return $string; + +} + +# print for sanity check +sub printNetworkGraph +{ + my $bpg = shift @_; + my @nodelist = @{$bpg->{'NodeList'}}; + my %nodetype = %{$bpg->{'NodeType'}}; + + #get atomic patterns + my @ap = grep { $nodetype{$_} eq 'AtomicPattern' } @nodelist; + # get binding sites + my @bs = sort {$a cmp $b} grep { $_ !~ /~/ and $_ !~ /\!/ } @ap; + # get internal states + my @is = sort {$a cmp $b} grep {$_ =~ /~/ } @ap; + # get bonds + my @bonds = sort {$a cmp $b} grep { $_ =~ /\!/ and $_ !~ /\!\+/ } @ap; + # wildcards + my @wc = sort {$a cmp $b} grep { $_ =~ /\!\+/ } @ap; + # rules + my @rules = sort {$a cmp $b} grep { $nodetype{$_} eq 'Rule' } @nodelist; + # groups + my %classes; + if(defined $bpg->{'NodeClass'}) {%classes = %{$bpg->{'NodeClass'}};} + + my @rulegroups; + my @patterngroups; + if($bpg->{'Collapsed'}==1) + { + @rulegroups = grep {$nodetype{$_} eq 'RuleGroup'} @nodelist; + @patterngroups = grep {$nodetype{$_} eq 'PatternGroup'} @nodelist; + } + else + { + my @classedrules = grep {$nodetype{$_} eq 'Rule'} keys %classes; + @rulegroups = map + { + my $x = $_; + $x.":".join(" ", + sort {$a cmp $b} + grep {$classes{$_} eq $x} @classedrules + ); + } + sort {$a cmp $b} + uniq( map $classes{$_}, @classedrules); + my @classedpatterns = grep {$nodetype{$_} eq 'AtomicPattern'} keys %classes; + @patterngroups = map + { + my $x = $_; + $x.":".join(" ", + sort {$a cmp $b} + grep {$classes{$_} eq $x} @classedpatterns + ); + } + sort {$a cmp $b} + uniq( map $classes{$_}, @classedpatterns); + } + + + my @str; + if(@bs) { push @str,"Binding Sites:\n".join("\n",@bs)."\n"; } + if(@is) { push @str,"Internal States:\n".join("\n",@is)."\n"; } + if(@bonds) { push @str,"Bonds:\n".join("\n",@bonds)."\n"; } + if(@wc) { push @str,"Wildcards:\n".join("\n",@wc)."\n"; } + if(@rules) { push @str,"Rules:\n".join("\n",@rules)."\n"; } + #if(@groups) + # { + # my @grpstrs = map {$names[$_].":".join(" ",@{$groups[$_]}) } 0..@groups-1; + # push @str,"Groups:\n".join("\n",@grpstrs)."\n"; + # } + if(@patterngroups) { push @str,"Pattern Groups:\n".join("\n",@patterngroups)."\n"; } + if(@rulegroups) { push @str,"Rule Groups:\n".join("\n",@rulegroups)."\n"; } + + my @edgelist = @{$bpg->{'EdgeList'}}; + my @reac = sort {$a cmp $b} map {$_ =~ /(.*:.*):.*/} grep {$_ =~ /Reactant$/} @edgelist; + my @prod = sort {$a cmp $b} map {$_ =~ /(.*:.*):.*/} grep {$_ =~ /Product$/} @edgelist; + my @context = sort {$a cmp $b} map {$_ =~ /(.*:.*):.*/} grep {$_ =~ /Context$/} @edgelist; + my @wildcards = sort {$a cmp $b} map {$_ =~ /(.*:.*):.*/} grep {$_ =~ /Wildcard$/} @edgelist; + + if(@reac) { push @str,"Reactant Relationships:\n".join("\n",@reac)."\n"; } + if(@prod) { push @str,"Product Relationships:\n".join("\n",@prod)."\n"; } + if(@context) { push @str,"Context Relationships:\n".join("\n",@context)."\n"; } + if(@wildcards) { push @str,"Wildcard Relationships:\n".join("\n",@wildcards)."\n"; } + + return join("\n",@str); +} +# text cleaning for atomic patterns and transformations +sub prettify +{ + my $string = shift @_; + my $arrow = '->'; + #print ($string, $string =~ /$arrow/, "\n"); + # check if it is a transformation + if ($string =~ /$arrow/) + { + # see if arrow has spaces already + if ($string =~ /\b$arrow\b/) { return $string;} + else + { + my @splits = split $arrow,$string; + if (scalar @splits == 1) { push @splits,"0"; } + elsif (length $splits[0] == 0) { $splits[0]="0";} + return join(" -> ",map prettify($_), @splits); + } + } + my $comma = ','; + if ($string =~ /$comma/) + { + if ($string =~ /\b$comma\b/) { return $string; } + else + { + my @splits = split $comma,$string; + return join(" , ", @splits); + } + } + #if ($string =~ /$0^/) { return $string; } + #if ($string =~ /\(/) { return $string; } + #else { return $string."\(\)"; } + return $string; +} + +sub unprettify +{ + my $string = shift @_; + $string =~ s/\s//g; + $string =~ s/\(\)//g; + $string =~ s/^0//g; + $string =~ s/0$//g; + return $string; +} + + + + +sub combine3 +{ + my @bpgs = @{shift @_}; + my @nodelist = (); + my @edgelist = (); + my %nodetype; + foreach my $bpg(@bpgs) + { + push @nodelist, @{$bpg->{'NodeList'}}; + push @edgelist, @{$bpg->{'EdgeList'}}; + foreach my $node( keys %{$bpg->{'NodeType'}} ) + { + $nodetype{$node} = $bpg->{'NodeType'}->{$node}; + } + + } + my $bpg = NetworkGraph->new(); + $bpg->{'NodeList'} = [uniq(@nodelist)]; + $bpg->{'EdgeList'} = [uniq(@edgelist)]; + $bpg->{'NodeType'} = \%nodetype; + return $bpg; +} +sub addWildcards +{ + my $bpg = shift @_; + my @nodelist = @{$bpg->{'NodeList'}}; + my %nodetype = %{$bpg->{'NodeType'}}; + + my @ap = grep {$nodetype{$_} eq 'AtomicPattern'} @nodelist; + my @wildcards = grep (isWildcard($_), @ap); + my @notwildcards = grep (!isWildcard($_), @ap); + + foreach my $wc(@wildcards) + { + my @splits = split '\+', $wc; + my $string = $splits[0]; + + my @matches = grep(index($_, $string) != -1, @notwildcards); + foreach my $match(@matches) + { + my $edge = makeEdge($wc,$match,'w'); + push @{$bpg->{'EdgeList'}},$edge; + } + } + return; +} + +# get methods +sub getReactantsProducts +{ + my $in = shift @_; + my $string = unprettify($in); + my @splits = split '->',$string; + my @reac = (); + my @prod = (); + if (scalar @splits == 1) { @reac = ($splits[0]); } + elsif (length $splits[0] == 0) { @prod = ($splits[1]); } + else { @reac = split ',',$splits[0]; @prod = split ',',$splits[1]; } + return (\@reac,\@prod); +} + +sub getStructures +{ + my @nodelist = @{shift @_}; + my %structures = ('Mol'=>1,'Comp'=>1,'CompState'=>1,'BondState'=>1,'GraphOp'=>0,'Rule'=>0); + my @nodes = grep( $structures{$_->{'Type'}}==1, @nodelist); + return @nodes; +} +sub getContext +{ + my @nodelist = @{shift @_}; + my @exclude = (); + if (@_) { @exclude = @{shift @_} }; + my @exclude_ids = (); + foreach my $exc (@exclude) + { + my @x = @$exc; + my $y = shift @x; + push @exclude_ids, map $_->{'ID'}, @x; + } + #print scalar @exclude_ids; + my @nodes_struct = getStructures(\@nodelist); + my @nodes = hasSide(\@nodes_struct,'both'); + my @context = (); + + # comp states + my @compstates = grep has(\@exclude_ids,$_->{'ID'})==0, + hasType(\@nodes,'CompState'); + if (@compstates) + { + foreach my $node(@compstates) + { + my $string = makeAtomicPattern(\@nodes_struct,$node); + if ($string) { push @context,$string;} + } + } + + # bond states + my @bondstates = grep has(\@exclude_ids,$_->{'ID'})==0, + hasType(\@nodes,'BondState'); + foreach my $node(@bondstates) + { + my $string = makeAtomicPattern(\@nodes_struct,$node); + if ($string) { push @context,$string;} + } + + # unbound states + my @comps = grep has(\@exclude_ids,$_->{'ID'})==0, + hasType(\@nodes,'Comp'); + my %unbound; + foreach my $x(@comps) { $unbound{$x->{'ID'}}=1; } + my @allbonds = hasType(\@nodelist,'BondState'); + my @allbondparents; + foreach my $node(@allbonds) { push @allbondparents, @{$node->{'Parents'}}; } + foreach my $x(@allbondparents) { $unbound{$x}=0; } + foreach my $x(keys %unbound) + { + if ($unbound{$x}) + { + my $node = findNode(\@comps,$x); + push @context,makeAtomicPattern(\@nodes_struct,$node); + } + } + + # mol nodes that do not have any components (hence identified by only label) + my @mols = hasType(\@nodes,'Mol'); + my %havenocomps; + foreach my $x(@mols) { $havenocomps{$x->{'ID'}}=1; } + my @allcompparents; + foreach my $node(hasType(\@nodes,'Comp')) + { push @allcompparents, @{$node->{'Parents'}}; } + foreach my $x(@allcompparents) { $havenocomps{$x}=0; } + foreach my $x(keys %havenocomps) + { + if ($havenocomps{$x}) + { + my $node = findNode(\@mols,$x); + push @context,makeAtomicPattern(\@nodes_struct,$node); + } + } + + return @context; +} + +sub getSyndelContext +{ + my @nodelist = @{shift @_}; + my $op = shift @_; + + my $mol = findNode(\@nodelist,${$op->{'Parents'}}[0]); + + # get child components + my @allcomps = hasType(\@nodelist,'Comp'); + my @comps = grep (${$_->{'Parents'}}[0] eq $mol->{'ID'}, @allcomps); + my @comps_ids = map $_->{'ID'}, @comps; + + # get child component states + my @allcompstates = hasType(\@nodelist,'CompState'); + my @compstates = (); + foreach my $x(@allcompstates) + { + foreach my $y (@comps_ids) + { + if (${$x->{'Parents'}}[0] eq $y) { push @compstates,$x; } + } + } + + # get child bond states + my %unbound; + foreach my $y (@comps_ids) { $unbound{$y} = 1; } + + my @allbondstates = hasType(\@nodelist,'BondState'); + my @bondstates = (); + foreach my $x(@allbondstates) + { + my @parents = @{$x->{'Parents'}}; + foreach my $y (@comps_ids) + { + foreach my $z(@parents) + { + if ($y eq $z) + { + push @bondstates,$x; + $unbound{$z} = 0; + } + } + } + } + + my @unboundcomps = (); + foreach my $x(keys %unbound) + { + if ($unbound{$x}) + { + my $node = findNode(\@nodelist,$x); + push @unboundcomps, $node; + } + } + + my @syndelnodes = (@compstates,@bondstates,@unboundcomps); + my @syndel = (); + foreach my $node(@syndelnodes) { push @syndel, makeAtomicPattern(\@nodelist,$node); } + + return @syndel; +} + +sub getTransformations +{ + my $rsg = shift @_; + my @nodelist = @{$rsg->{'NodeList'}}; + my @graphop = hasType(\@nodelist,'GraphOp'); + my @tr = map {makeTransformation(\@nodelist,$_);} @graphop; + return @tr; +} +sub reverseTransformation +{ + my $tr = shift @_; #unprettified + my @splits = reverse split('->',prettify($tr)); + #my @splits2 = map ( join(',',sort split(',',$_ =~ s/\s//g)), @splits); + sub clean { $_ =~ s/\s//g; return $_; } + my @splits2 = map ( join(',',sort split(',',clean($_))), @splits); + my $tr2 = unprettify(join '->',@splits2 ); + return $tr2; +} + +sub stringToAtomicPattern +{ + my $pat = shift @_; + my $patstr = $pat; + my $sg = SpeciesGraph->new(); + my $err = SpeciesGraph::readString($sg,\$patstr); + my $psg = makePatternStructureGraph($sg); + my @nodes = @{$psg->{'NodeList'}}; + my @ap = uniq(makeAtomicPatterns(\@nodes,\@nodes)); + my @pats; + if($pat =~ /\!/ and $pat !~ /\!\+/) + { + @pats = grep { $_ =~ /\!/ } @ap; + } + elsif($pat =~ /\!\+/) + { + @pats = grep { $_ =~ /\!\+/ } @ap; + } + elsif($pat =~ /~/) + { + @pats = grep { $_ =~ /~/ } @ap; + } + elsif($pat =~ /\(.{1,}\)/) + { + @pats = grep { $_ =~ /\(.{1,}\)/ } @ap; + } + elsif($pat =~ /\(\)/) + { + @pats = @ap; + } + if (scalar @pats != 1) + { + return $pat; + } + return $pats[0]; +} + +# make graph methods +sub makeRuleNetworkGraph +{ + # from a rule structure graph + my $rsg = shift @_; + my $name = shift @_; + # process name so that it doesnt begin with a number + $name = ($name =~ /^[0-9]/) ? "_".$name : $name; + + my @nodelist = @{$rsg->{'NodeList'}}; + + my $bpg = NetworkGraph->new(); + $bpg->{'Name'} = $name; + + my @graphop = hasType(\@nodelist,'GraphOp'); + my @contexts = getContext(\@nodelist); + + # add node for rule + push @{$bpg->{'NodeList'}}, $name; + $bpg->{'NodeType'}->{$name} = 'Rule'; + + # add reactant and product edges + foreach my $op(@graphop) + { + my $tr = makeTransformation(\@nodelist,$op); + if($op->{'Name'} eq 'DeleteBond') + { + $tr = makeTransformationDeleteBond(\@nodelist,$op); + # bond deletion is treated here + # if there's a deletemol, AB -> A, then it shows only A as the product + # wildcard delete! if A!+ -> A, then this shows A as the product + # if A!? -> 0, ignore. Is this bad form? Testing needed. + } + if(not defined $tr) { next; } + if(length $tr == 0) { next; } + my ($reac,$prod) = getReactantsProducts($tr); + push @{$bpg->{'NodeList'}}, @$reac, @$prod; + foreach my $reactant (@$reac) + { + if (length $reactant == 0) {next;} + my $edge = makeEdge($name,$reactant,'r'); + push @{$bpg->{'NodeList'}}, $reactant; + push @{$bpg->{'EdgeList'}}, $edge; + $bpg->{'NodeType'}->{$reactant} = 'AtomicPattern'; + + } + foreach my $product (@$prod) + { + if (length $product == 0) {next;} + my $edge = makeEdge($name,$product,'p'); + push @{$bpg->{'NodeList'}}, $product; + push @{$bpg->{'EdgeList'}}, $edge; + $bpg->{'NodeType'}->{$product} = 'AtomicPattern'; + } + } + # add context edges + foreach my $context(@contexts) + { + if (length $context == 0) {next;} + my $edge = makeEdge($name,$context,'c'); + push @{$bpg->{'NodeList'}}, $context; + push @{$bpg->{'EdgeList'}}, $edge; + $bpg->{'NodeType'}->{$context} = 'AtomicPattern'; + } + # add syndel edges + foreach my $op(@graphop) + { + if ($op->{'Name'} =~ /Mol/) + { + my $rel = ($op->{'Name'} =~ /Add/) ? 'p' : 'r'; + my @syndels = getSyndelContext(\@nodelist,$op); + foreach my $syndel(@syndels) + { + if (length $syndel == 0) {next;} + my $edge = makeEdge($name,$syndel,$rel); + push @{$bpg->{'NodeList'}}, $syndel; + push @{$bpg->{'EdgeList'}}, $edge; + $bpg->{'NodeType'}->{$syndel} = 'AtomicPattern'; + } + } + } + + uniqNetworkGraph($bpg); + addWildcards($bpg); + uniqNetworkGraph($bpg); + return $bpg; + +} + +sub makeRxnNetworkGraph +{ + my $rxn = shift @_; + my @reac = map {$_->SpeciesGraph->toString()} @{$rxn->Reactants}; + my @prod = map {$_->SpeciesGraph->toString()} @{$rxn->Products}; + my $name = "Rxn".$rxn->Index; + my @nodes = uniq($name,@reac,@prod); + my %nodetype; + $nodetype{$name} = "Rule"; + map {$nodetype{$_} = "AtomicPattern"} (@reac,@prod); + my @edges = (); + foreach my $sp(@reac) + { + push @edges, makeEdge($name,$sp,"r"); + } + foreach my $sp(@prod) + { + push @edges, makeEdge($name,$sp,"p"); + } + my $bpg = makeRuleNetworkGraph_simple(\@nodes,\@edges,\%nodetype); + return $bpg; +} +sub makeRuleNetworkGraph_simple +{ + my @nodes = @{shift @_}; + my @edges = @{shift @_}; + my %nodetype = %{shift @_}; + my $name = shift @_; + + my $bpg = NetworkGraph->new(); + $bpg->{'NodeType'} = \%nodetype; + $bpg->{'NodeList'} = \@nodes; + $bpg->{'EdgeList'} = \@edges; + $bpg->{'Name'} = $name; + return $bpg; + +} + +sub makeRuleNetworkGraphFromEdges +{ + my @edges = @{shift @_}; + my %nodetype = %{shift @_}; + my $name = shift @_; + + my @nodes = uniq(map {$_=~ /^(.*):(.*):.*/; ($1,$2);} @edges); + my %types; + updateDict(\%types,\%nodetype,\@nodes); + my $bpg = NetworkGraph->new(); + $bpg->{'NodeType'} = \%nodetype; + $bpg->{'NodeList'} = \@nodes; + $bpg->{'EdgeList'} = \@edges; + $bpg->{'Name'} = $name; + return $bpg; + +} + + +# do things to network graphs +sub uniqNetworkGraph +{ + my $bpg = shift(@_); + $bpg->{'NodeList'} = [uniq(@{$bpg->{'NodeList'}})]; + $bpg->{'EdgeList'} = [uniq(@{$bpg->{'EdgeList'}})]; + return; +} +sub mergeNetworkGraphs +{ + my @x = @_; + my $bpg = combine3(\@x); + uniqNetworkGraph($bpg); + addWildcards($bpg); + uniqNetworkGraph($bpg); + $bpg->{'Merged'} =1; + return $bpg; +} +sub resolveWildcards +{ + my $bpg = shift @_; + my @edgelist = @{$bpg->{'EdgeList'}}; + my %nodetype = %{$bpg->{'NodeType'}}; + my @nodelist = @{$bpg->{'NodeList'}}; + my @wc_edges = grep {$_ =~ /Wildcard$/} @edgelist; + # don't do any work if there are no wildcards + return $bpg if( not @wc_edges ); + + print "Resolving wildcard edges.\n"; + + my @wcs = grep { index($_,'!+') != -1 } + grep { $nodetype{$_} eq 'AtomicPattern'} + @nodelist; + my @wc_context = grep {$_ =~ /.*:(.*):.*/; my $x = $1; index($1,'!+') != -1;} + grep {$_ =~ /Context$/} + @edgelist; + my @new_edges; + foreach my $wc(@wcs) + { + my @r = map { $_ =~ /(.*):.*:.*/; $1; } + grep { $_ =~ /.*:(.*):.*/; my $x = $1; index($x,$wc) != -1; } + @wc_context; + my @b = map { $_ =~ /.*:(.*):.*/; $1; } + grep { $_ =~ /^(.*):.*:.*/; my $x = $1; index($x,$wc) != -1; } + @wc_edges; + foreach my $rule(@r) + { + foreach my $bond(@b) + { + push @new_edges, join(":",($rule,$bond,'Context')); + } + } + } + + my @nodelist2 = grep { not has(\@wcs,$_); } @nodelist; + my @edges_to_remove = (@wc_edges,@wc_context); + my @edgelist2 = grep { not has(\@edges_to_remove,$_); } @edgelist; + push @edgelist2,@new_edges; + + @nodelist2= uniq(@nodelist2); + @edgelist2 = uniq(@edgelist2); + + my %nodetype2; + updateDict(\%nodetype2,\%nodetype,\@nodelist2); + + my $bpg2 = NetworkGraph->new(); + $bpg2->{'NodeList'} = \@nodelist2; + $bpg2->{'EdgeList'} = \@edgelist2; + $bpg2->{'NodeType'} = \%nodetype2; + + return $bpg2; +} + +sub filterNetworkGraph +{ + # when $reverse is not mentioned, it simply removes the nodes that are + # included in @$filter from the bpg + # when $reverse eq 'reverse', it removes everything BUT those nodes + my $bpg = shift @_; + my $filter = shift @_; + my $reverse = @_ ? shift @_ : ''; + my $includegroups = @_ ? shift @_ : 0; + + my @nodelist = @{$bpg->{'NodeList'}}; + my @edgelist = @{$bpg->{'EdgeList'}}; + my %nodetype = %{$bpg->{'NodeType'}}; + + + if( $reverse eq 'reverse' ) + { + # this is if a reverse + my @filter2 = grep { has($filter,$_)==0; } @nodelist; + $filter = \@filter2; + } + + my @new_nodelist = grep { has($filter,$_)==0; } @nodelist; + my %new_nodetype = map { $_=>$nodetype{$_} } @new_nodelist; + + + my @removed_edges; + my @remove1 = grep { + my $x = $_; + $x =~ /.*:(.*):.*/; + has($filter,$1)==1; + } @edgelist; + my @remove2 = grep { + my $x = $_; + $x =~ /(.*):.*:.*/; + has($filter,$1)==1; + } @edgelist; + my @new_edgelist = grep { has([(@remove1,@remove2)],$_)==0;} @edgelist; + + my $bpg2 = NetworkGraph->new(); + $bpg2->{'NodeList'} = \@new_nodelist; + $bpg2->{'EdgeList'} = \@new_edgelist; + $bpg2->{'NodeType'} = \%new_nodetype; + $bpg2->{'Merged'} = $bpg->{'Merged'}; + $bpg2->{'Filtered'} = 1; + $bpg2->{'Collapsed'} = $bpg->{'Collapsed'}; + + if($includegroups and defined $bpg->{'NodeClass'}) + { + my %nodeclass = %{$bpg->{'NodeClass'}}; + my %new_nodeclass = map { $_=>$nodeclass{$_} } @new_nodelist; + $bpg2->{'NodeClass'} = \%new_nodeclass; + } + + return $bpg2; +} + +sub filterNetworkGraphByList +{ + my $bpg = shift @_; + my @items = @{shift @_}; + my $level = @_ ? shift @_ : 1; + + my @nodes = @{$bpg->{'NodeList'}}; + my @edges = @{$bpg->{'EdgeList'}}; + + for (my $i=1; $i<=$level; $i++) + { + my @items2=(); + foreach my $edge(@edges) + { + $edge =~ /(.*):(.*):.*/; + my $x = $1; my $y = $2; + next if(has(\@items,$x)==has(\@items,$y)); + if(has(\@items,$x)==0) { push @items2,$x; } + if(has(\@items,$y)==0) { push @items2,$y; } + #print scalar @items2;print "\n"; + } + push @items,uniq(@items2); + } + #print @items; + @items = uniq(@items); + my @remove = grep { has(\@items,$_)==0; } @{$bpg->{'NodeList'}}; + my $bpg2 = filterNetworkGraph($bpg,\@remove); + uniqNetworkGraph($bpg2); + if(defined $bpg->{'NodeClass'}) + { + my %classes; + updateDict(\%classes,$bpg->{'NodeClass'},$bpg2->{'NodeList'}); + $bpg2->{'NodeClass'} = \%classes; + } + return $bpg2; +} + +sub collapseNetworkGraph +{ + + my $bpg = shift @_; + my $doNotCollapseEdges = @_ ? shift @_ : 0; + my %classes = %{$bpg->{'NodeClass'}}; + + + my @classed = keys %classes; + my @edges = @{$bpg->{'EdgeList'}}; + + my @classed_rules = grep {$bpg->{'NodeType'}->{$_} eq 'Rule'} keys %classes; + my @classed_patterns = grep {$bpg->{'NodeType'}->{$_} eq 'AtomicPattern'} keys %classes; + my @rule_classes = uniq(map $classes{$_}, @classed_rules); + my @pattern_classes = uniq(map $classes{$_}, @classed_patterns); + + my @nodelist2; + my @edgelist2; + my %nodetype2; + foreach my $edge(@edges) + { + # deconstruct edge + $edge =~ /^(.*):(.*):(.*)$/; + my $x = $1; + my $y = $2; + my $z = $3; + + if(has([qw(Reactant Product Context Inhibition)],$z) ) + { + if(has(\@classed_rules,$x)) { $x = $classes{$x}; } + if(has(\@classed_patterns,$y)) { $y = $classes{$y}; } + } + if($z eq 'Wildcard') + { + if(has(\@classed_patterns,$x)) { $x = $classes{$x}; }; + if(has(\@classed_patterns,$y)) { $y = $classes{$y}; }; + next if($x eq $y); + } + + #pushy stuff + push @nodelist2, $x; + push @nodelist2, $y; + push @edgelist2, join(":",($x,$y,$z)); + + if(has(\@rule_classes,$x)) { $nodetype2{$x} = 'RuleGroup'; } + elsif(has(\@pattern_classes,$x)) { $nodetype2{$x} = 'PatternGroup'; } + else {$nodetype2{$x} = $bpg->{'NodeType'}->{$x}; } + + if(has(\@pattern_classes,$y)) { $nodetype2{$y} = 'PatternGroup'; } + else {$nodetype2{$y} = $bpg->{'NodeType'}->{$y}; } + } + + @nodelist2= uniq(@nodelist2); + if ($doNotCollapseEdges==0) { @edgelist2 = uniq(@edgelist2);} + + + my $bpg2 = NetworkGraph->new(); + $bpg2->{'NodeList'} = \@nodelist2; + $bpg2->{'EdgeList'} = \@edgelist2; + $bpg2->{'NodeType'} = \%nodetype2; + $bpg2->{'Merged'} = $bpg->{'Merged'}; + $bpg2->{'Collapsed'} = 1; + + return $bpg2; +} + +sub updateDict +{ + my $update_this = shift @_; + my $update_using = shift @_; + my $update_list = shift @_; + + #my @keys1 = keys %{$update_this}; + my @keys2 = keys %{$update_using}; + my @common_keys = grep { has(\@keys2,$_) } @{$update_list}; + + map { $update_this->{$_} = $update_using->{$_} } @common_keys; + return; +} + +sub duplicateNetworkGraph +{ + my $bpg = shift @_; + my $bpg2 = NetworkGraph->new(); + + $bpg2->{'NodeList'} = \@{$bpg->{'NodeList'}}; + $bpg2->{'EdgeList'} = \@{$bpg->{'EdgeList'}}; + $bpg2->{'NodeType'} = \%{$bpg->{'NodeType'}}; + if(defined $bpg->{'NodeClass'}) + { $bpg2->{'NodeClass'} = \%{$bpg->{'NodeClass'}}; } + $bpg2->{'Merged'} = $bpg->{'Merged'}; + $bpg2->{'Collapsed'} = $bpg->{'Collapsed'}; + $bpg2->{'Filtered'} = $bpg->{'Filtered'}; + return $bpg2; + +} +1; + diff --git a/libvcell/vcell_install/bionetgen/Perl2/Visualization/ProcessGraph.pm b/libvcell/vcell_install/bionetgen/Perl2/Visualization/ProcessGraph.pm new file mode 100644 index 0000000..f2350c5 --- /dev/null +++ b/libvcell/vcell_install/bionetgen/Perl2/Visualization/ProcessGraph.pm @@ -0,0 +1,584 @@ +package Viz; + +use strict; +use warnings; +no warnings 'redefine'; + +use Class::Struct; +use Visualization::NetworkGraph; +use Visualization::GML; + + +struct ProcessGraph => +{ + 'Processes' => '@', + 'Edges' => '@', + 'ReacProds' => '%', # to be deprecated + 'Names' => '%', + 'Embed' => '%', +}; + +struct ProcessGraph2 => +{ + 'Nodes'=> '@', + 'Edges'=> '@', + 'Embed'=> '@', + 'Names'=> '@', + +}; +sub initializeProcessGraph +{ + my $pg = ProcessGraph2->new(); + $pg->{'Nodes'} = shift @_; + $pg->{'Edges'} = shift @_; + if(@_) { $pg->{'Embed'} = shift @_; } + if(@_) { $pg->{'Names'} = shift @_; } + #else {my @x = @{$pg->{'Nodes'}}; $pg->{'Names'} = \@x;} + #print @{$pg->{'Names'}}; + return $pg; +} +sub printProcessGraph +{ + my $pg = shift @_; + my $str = (); + $str .= "Processes:\n"; + $str .= join "\n", map { $_.":".$pg->{'Names'}->{$_} } @{$pg->{'Processes'}}; + $str .= "\n"; + $str .= "Influences:\n"; + $str .= join "\n", @{$pg->{'Edges'}}; + return $str; + +} + +sub makeProcessGraph +{ + print "Building process graph for whole model.\n"; + my $bpg = shift @_; + + my $mergepairs = @_ ? shift @_ : 0; + my $embed = @_ ? shift @_ : 0; + + my @edges = @{$bpg->{'EdgeList'}}; + my @edges2; + + my @processes = grep {$bpg->{'NodeType'}->{$_} =~ /Rule/} @{$bpg->{'NodeList'}}; + my @wcs = uniq(map {$_ =~ /^(.*):.*:.*/; $1; } grep { $_ =~ /Wildcard/ } @edges); + + my %reacprod; + my %context; + my %reac; + my %prod; + map { my @x = (); $reacprod{$_} = \@x; } @processes; + map { my @x = (); $context{$_} = \@x; } @processes; + + foreach my $proc(@processes) + { + my $r = quotemeta $proc; + my @rps = uniq( map { $_ =~ /.*:(.*):.*/; $1; } + grep { $_ =~ /Reactant|Product/ } + grep {$_ =~ /^$r:/ } @edges ); + if(@wcs) { push @rps, getWCs(\@rps,\@wcs,\@edges); } + $reacprod{$proc} = \@rps; + + my @cont = uniq( map { $_ =~ /.*:(.*):.*/; $1; } + grep { $_ =~ /Context/ } + grep {$_ =~ /^$r:/ } @edges ); + $context{$proc} = \@cont; + } + foreach my $r1(@processes) + { + foreach my $r2(@processes) + { + if(has_overlap($reacprod{$r1},$context{$r2})) + { + push @edges2, join(" ",($r1,$r2)); + } + } + } + my %namesarr; + my %bpgs; + foreach my $proc(@processes) + { + my $r = quotemeta $proc; + my @reacs = sort {$a cmp $b} + uniq( map { $_ =~ /.*:(.*):.*/; $1; } + grep { $_ =~ /Reactant/ } + grep {$_ =~ /^$r:/ } @edges ); + $reac{$proc} = \@reacs; + + my @prods = sort {$a cmp $b} + uniq( map { $_ =~ /.*:(.*):.*/; $1; } + grep { $_ =~ /Product/ } + grep {$_ =~ /^$r:/ } @edges ); + $prod{$proc} = \@prods; + + my $namearr = [[$proc],\@reacs,\@prods]; + #my $name = $proc."\n:".join("+",@reacs)."->".join("+",@prods)." }"; + #my $name = make_name($namearr); + $namesarr{$proc} = $namearr; + + # building embed graph here + if($embed) + { + my @embed_edges = grep { $_ =~ /Reactant|Product/ } + grep {$_ =~ /^$r:/ } @edges ; + my @embed_nodes = uniq( map { $_ =~ /.*:(.*):.*/; $1; } @embed_edges); + push @embed_nodes,$proc; + my %embed_nodetype; + my %nodetype = %{$bpg->{'NodeType'}}; + @embed_nodetype { @embed_nodes } = @nodetype {@embed_nodes}; + my $bpg2 = makeRuleNetworkGraph_simple(\@embed_nodes,\@embed_edges,\%embed_nodetype,$proc); + $bpgs{$proc} = $bpg2; + } + } + + my %names; + map {$names{$_} = make_name($namesarr{$_});} @processes; + + my $pg = ProcessGraph->new(); + if($mergepairs==0) + { + $pg->{'Processes'} = \@processes; + #$pg->{'ReacProds'} = \%reacprod; + $pg->{'Names'} = \%names; + $pg->{'Edges'} = \@edges2; + if($embed) {$pg->{'Embed'} = \%bpgs;} + return $pg; + } + + # mergepairs needs to be done correctly! + my @procs = @processes; + my @pairs; + my @unpaired; + if($mergepairs==1) + { + # build pairs; + # get a process from the stack + my @stack = @processes; + + while(@stack) + { + my $proc1 = shift @stack; + my @stack2 = @stack; + my @stack3; + while(@stack2) + { + my $proc2 = shift @stack2; + if(is_reverse_of($reac{$proc1},$prod{$proc1},$reac{$proc2},$prod{$proc2})) + { + push @pairs, $proc1." ".$proc2; + #$pairs{$proc1} = $proc2; + last; + } + else + { + push @stack3,$proc2; + } + if(not @stack2) { push @unpaired,$proc1;} + } + @stack = (@stack2,@stack3); + } + } + + my @procs_p; + my @edges_p; + my %names_p; + my %embed_p; + my %remaphash; + my %bpgs_p; + foreach my $pair(@pairs) + { + my ($dom,$sub) = split(" ",$pair); + my $proc = join(",",($dom,$sub)); + push @procs_p, $proc; + $remaphash{$dom} = $proc; + $remaphash{$sub} = $proc; + + my @name_arr = @{$namesarr{$dom}}; + push2ref($name_arr[0],$sub); + my $name = make_name(\@name_arr); + $names_p{$proc} = $name; + if($embed) + { + my @bpgs2 = map {$bpgs{$_} } ($dom,$sub); + my $bpg = mergeNetworkGraphs(@bpgs2); + $bpgs_p{$proc} = $bpg; + } + } + foreach my $proc(@unpaired) + { + push @procs_p, $proc; + $remaphash{$proc} = $proc; + my $name = make_name($namesarr{$proc}); + $names_p{$proc} = $name; + if($embed) + { + $bpgs_p{$proc} = $bpgs{$proc}; + } + } + @edges_p =uniq( map + { + my @x = split(" ",$_); + join(" ",map {$remaphash{$_}} @x); + } @edges2); + + + $pg->{'Processes'} = \@procs_p; + #$pg->{'ReacProds'} = \%reacprod; + $pg->{'Names'} = \%names_p; + $pg->{'Edges'} = \@edges_p; + if($embed) {$pg->{'Embed'} = \%bpgs_p;} + return $pg; + +} + +sub reprocessWildcards +{ + my @edgelist = @{shift @_}; + my @wc_edges = grep {$_ =~ /.*:.*:Wildcard$/ } @edgelist ; + my @wcs = uniq (map {$_ =~ /^(.*):.*:.*/; $1; } @wc_edges); + my @other_edges = grep { not has(\@wc_edges,$_) } @edgelist; + + my @edges2; + foreach my $edge(@other_edges) + { + $edge =~ /^(.*):(.*):(.*)$/; + my ($rule,$pat,$rel) = ($1,$2,$3); + if($rel ne 'Context') { push @edges2,$edge; next;} + if(not has(\@wcs,$pat)) { push @edges2,$edge; next;} + + my @matches = uniq( map {$_ =~ /^.*:(.*):.*$/; $1;} grep {$_ =~ /^(.*):.*:.*$/; $1 eq $pat} @wc_edges); + foreach my $pat2(@matches) { push @edges2, join(":",($rule,$pat2,$rel)); } + } + return uniq(@edges2); +} + +sub makeProcessGraph2 +{ + my $bpg = shift @_; + my %nodetype = %{$bpg->{'NodeType'}}; + my @allnodes = @{$bpg->{'NodeList'}}; + my @alledges = reprocessWildcards($bpg->{'EdgeList'}); + + + my %args = %{shift @_}; + my @processgrps = (); + my $pg; + + if($args{'groups'}==0) + { + if($args{'mergepairs'}==0) + { + my @rules = grep { $nodetype{$_} eq 'Rule' } @allnodes; + my @reacprods = map [getRelationships(\@alledges,$_,['Reactant','Product'])], @rules; + my @contexts = map [getRelationship(\@alledges,$_,'Context')], @rules; + + my @processes = @rules; + my @relations = (); + foreach my $i(0..@processes-1) + { + foreach my $j($i..@processes-1) + { + if( has_overlap($reacprods[$i],$contexts[$j]) ) + { push @relations, join(" ",($i,$j));} + next if($i == $j); + if( has_overlap($reacprods[$j],$contexts[$i]) ) + { push @relations, join(" ",($j,$i));} + + } + } + @relations = uniq(@relations); + my @names = ($args{'embed'}==0) ? @processes : () x @processes; + $pg = initializeProcessGraph(\@processes,\@relations,[],\@names); + } + else + { + my @rules = grep { $nodetype{$_} eq 'Rule' } @allnodes; + # group rules and their reverses + my %revmap; + foreach my $rule(@rules) + { + # stupid naming conventions! + if($rule =~ /^(Rule[0-9].*)r$/) + { + my $pair = $1; + if(has(\@rules,$pair)) {$revmap{$rule} = $pair;} + } + elsif($rule =~ /^(.*)\(reverse\)$/) + { + my $pair = $1; + if(has(\@rules,$pair)) {$revmap{$rule} = $pair;} + } + } + my @paired = (keys %revmap,values %revmap); + my @stack = (); + foreach my $rule(@rules) + { + if(not has(\@paired,$rule)) { my @x = ($rule); push @stack, \@x;} + if(has([keys %revmap],$rule)) { push @stack, [$revmap{$rule},$rule]; } + } + + my @processes = @stack; + my @reacprods = map { + my @x = @$_; + my @y = map getRelationships(\@alledges,$_,['Reactant','Product']),@x; + \@y; + } @processes; + my @contexts = map { + my @x = @$_; + my @y = map getRelationship(\@alledges,$_,'Context'),@x; + \@y; + } @processes; + + my @relations = (); + foreach my $i(0..@processes-1) + { + foreach my $j($i..@processes-1) + { + if( has_overlap($reacprods[$i],$contexts[$j]) ) + { push @relations, join(" ",($i,$j));} + next if($i == $j); + if( has_overlap($reacprods[$j],$contexts[$i]) ) + { push @relations, join(" ",($j,$i));} + } + } + @relations = uniq(@relations); + + my @pr1 = map join(",",@$_), @processes; + my @names = ($args{'embed'}==0) ? @pr1 : () x @pr1; + $pg = initializeProcessGraph(\@processes,\@relations,[],\@names); + } + } + + if($args{'groups'}==1) + { + my @rules = grep { $nodetype{$_} eq 'Rule' } @allnodes; + my %nodeclass = %{$bpg->{'NodeClass'}}; + my %extended; + foreach my $node(@allnodes) + { + if(has([keys %nodeclass],$node)) { $extended{$node} = $nodeclass{$node}; } + else { $extended{$node} = $node; } + } + my @processes = uniq( map $extended{$_}, @rules); + my @reacprods = map { + my $p = $_; + my @x = grep {$extended{$_} eq $p} @rules; + my @y = map getRelationships(\@alledges,$_,['Reactant','Product']),@x; + my @z = uniq( map {$extended{$_}} @y ); + \@z; + } @processes; + my @contexts = map { + my $p = $_; + my @x = grep {$extended{$_} eq $p} @rules; + my @y = map getRelationship(\@alledges,$_,'Context'),@x; + my @z = uniq( map {$extended{$_}} @y ); + \@z; + } @processes; + + if($args{'mergepairs'}==0) + { + my @relations = (); + foreach my $i(0..@processes-1) + { + foreach my $j($i..@processes-1) + { + if( has_overlap($reacprods[$i],$contexts[$j]) ) + { push @relations, join(" ",($i,$j));} + next if($i == $j); + if( has_overlap($reacprods[$j],$contexts[$i]) ) + { push @relations, join(" ",($j,$i));} + } + } + @relations = uniq(@relations); + + #my @names = @processes; + my @names = ($args{'embed'}==0) ? @processes : () x @processes; + $pg = initializeProcessGraph(\@processes,\@relations,[],\@names); + } + else + { + my @procs2; + my @reacprods2; + my @contexts2; + my %merged; + @merged { 0..@processes-1 } = (0) x @processes; + foreach my $i(0..@processes-1) + { + next if ($merged{$i}==1); + my @rp1 = sort {$a cmp $b} uniq(@{$reacprods[$i]}); + foreach my $j(($i+1)..@processes-1) + { + my @rp2 = sort {$a cmp $b} uniq(@{$reacprods[$j]}); + if( arrayEquals(\@rp1,\@rp2) ) + { + push @procs2, [$processes[$i],$processes[$j]]; + push @reacprods2, \@rp1; + my @x = (@{$contexts[$i]},@{$contexts[$j]}); + push @contexts2,\@x; + $merged{$i} = 1; + $merged{$j} = 1; + } + } + if($merged{$i} == 0) + { + push @procs2, [$processes[$i]]; + push @reacprods2, \@rp1; + push @contexts2,[uniq(@{$contexts[$i]})]; + } + } + my @relations = (); + foreach my $i(0..@procs2-1) + { + foreach my $j($i..@procs2-1) + { + if( has_overlap($reacprods2[$i],$contexts2[$j]) ) + { push @relations, join(" ",($i,$j));} + next if($i == $j); + if( has_overlap($reacprods2[$j],$contexts2[$i]) ) + { push @relations, join(" ",($j,$i));} + } + } + @relations = uniq(@relations); + my @pr1 = map join(",",@$_), @procs2; + my @names = ($args{'embed'}==0) ? @pr1 : () x @pr1; + $pg = initializeProcessGraph(\@procs2,\@relations,[],\@names); + } + } + return $pg; +} + +sub embedProcessGraph +{ + my $pg = shift @_; + my $gr = shift @_; + my %args = %{shift @_}; + my $bpg = $gr->{'RuleNetworkCurrent'}; + my $bpg2; + #my $bpg2 = collapseNetworkGraph($bpg); + + my @nodes = @{$pg->{'Nodes'}}; + my @names = @{$pg->{'Names'}}; + my @embed = () x @nodes; + my $mergepairs = $args{'mergepairs'}; + my $groups = $args{'groups'}; + if($groups) {$bpg2 = collapseNetworkGraph($bpg);} + else {$bpg2 = $bpg;} + + my @reacprods = grep {$_ =~ /^.*:.*:(.*)/; has(['Reactant','Product'],$1);} + @{$bpg2->{'EdgeList'}}; + my @rsgs = map {@$_;} flat($gr->{'RuleStructureGraphs'}); + my @rnames = map {@$_;} flat($gr->{'RuleNames'}); + foreach my $i(0..@nodes-1) + { + my $node = $nodes[$i]; + my @arr = ($mergepairs==1) ? @$node : ($node); + if($groups==1) + { + my @edges = map { + my $x = $_; + grep {$_ =~ /^(.*):.*:.*/; $1 eq $x} + @reacprods + } @arr; + @edges = uniq(@edges); + $embed[$i] = makeRuleNetworkGraphFromEdges(\@edges,$bpg2->{'NodeType'},$names[$i]); + } + else + { + my @rsgs1 = map { + my $x = $_; + map {$rsgs[$_]} + grep {$rnames[$_] eq $x} 0..@rnames-1; + } @arr; + $embed[$i] = combine2(\@rsgs1); + } + } + $pg->{'Embed'} = \@embed; + return; +} +sub getRelationship +{ + my @edgelist = @{shift @_}; + my $node = shift @_; + my $reltype = shift @_; + + my @edges = grep { $_ =~ /.*:.*:(.*)$/; $1 eq $reltype} @edgelist; + my @arr1 = map { $_ =~ /^(.*):.*:.*$/; $1;} grep { $_ =~ /.*:(.*):.*$/; $1 eq $node} @edges; + my @arr2 = map { $_ =~ /.*:(.*):.*$/; $1;} grep { $_ =~ /^(.*):.*:.*$/; $1 eq $node} @edges; + return (@arr1,@arr2); +} + +sub getRelationships +{ + my $edgelist = shift @_; + my $node = shift @_; + my @reltypes = @{shift @_}; + my @arr = map {getRelationship($edgelist,$node,$_)} @reltypes; + return @arr; +} +sub is_reverse_of +{ + my @proc1_reac = sort {$a cmp $b} @{shift @_}; + my @proc1_prod = sort {$a cmp $b} @{shift @_}; + my @proc2_reac = sort {$a cmp $b} @{shift @_}; + my @proc2_prod = sort {$a cmp $b} @{shift @_}; + my $ret = 0; + $ret = 1 if(scalar @proc1_reac and arrayEquals(\@proc1_reac,\@proc2_prod)); + $ret = 1 if(scalar @proc1_prod and arrayEquals(\@proc1_prod,\@proc2_reac)); + return $ret; +} + +sub has_overlap +{ + my @x = @{shift @_}; + my @y = @{shift @_}; + my @z = grep {has(\@y,$_) } @x; + return (scalar(@z) > 0) ? 1: 0; +} +sub getWCs +{ + my @aps = @{shift @_}; + my @wcs = @{shift @_}; + my @edges = @{shift @_}; + my @rets = (); + foreach my $ap(@aps) + { + foreach my $wc(@wcs) + { + my $str = join(":",($wc,$ap,'Wildcard')); + my @matches = grep {$_ eq $str} @edges; + if(@matches) { push @rets,map {$_ =~ /^(.*):.*:.*/; $1; } @matches; } + } + } + return uniq(@rets); +} + +sub make_name +{ + my ($x,$y,$z) = @{shift @_}; + my @procs = @$x; + my @reac = sort {$a cmp $b} @$y; + my @prod = sort {$a cmp $b} @$z; + + my $str1 = join(",",@procs); + my $str2 = join("+",@reac); + my $str3 = join("+",@prod); + + my $arrow = (scalar @procs > 1) ? "<->" : "->"; + #return $str1."\n".$str2.$arrow.$str3; + return $str2.$arrow.$str3; +} + +sub arrayEquals +{ + my @arr1 = sort {$a cmp $b} @{shift @_}; + my @arr2 = sort {$a cmp $b} @{shift @_}; + + return 0 if (scalar @arr1 != scalar @arr2); + foreach my $i(0..@arr1-1) + { + return 0 if ($arr1[$i] ne $arr2[$i]); + } + return 1; +} +1; diff --git a/libvcell/vcell_install/bionetgen/Perl2/Visualization/README b/libvcell/vcell_install/bionetgen/Perl2/Visualization/README new file mode 100644 index 0000000..93575a8 --- /dev/null +++ b/libvcell/vcell_install/bionetgen/Perl2/Visualization/README @@ -0,0 +1,34 @@ +VISUALIZATION TOOL +------------------ + John A.P. Sekar (johnarul.sekar@gmail.com) + +The visualize() action and the visualize.pl tool generate GML files. +They are best viewed using yEd Graph Editor available for free at +(http://www.yworks.com/en/products_yed_download.html). + +Using visualize() action +------------------------ + visualize({type=>"TYPE"}) + +Using visualize.pl +------------------ + perl visualize.pl --bngl BNGL --type TYPE + +Allowed values for TYPE +----------------------- + conventional conventional rule visualization + compact compact rule visualization (using graph operation nodes) + regulatory rule-derived regulatory graph + opts options template for regulatory graph + contactmap contact map + reaction_network reaction network + +Getting help +------------ +Using the visualize() action, try: + visualize({help=>1}) + +Using visualize.pl, try: + perl visualize.pl --help + +If you have any questions about using this tool, please email us at bionetgen.help@gmail.com diff --git a/libvcell/vcell_install/bionetgen/Perl2/Visualization/RINF.pm b/libvcell/vcell_install/bionetgen/Perl2/Visualization/RINF.pm new file mode 100644 index 0000000..485d788 --- /dev/null +++ b/libvcell/vcell_install/bionetgen/Perl2/Visualization/RINF.pm @@ -0,0 +1,119 @@ +package Viz; + +use strict; +use warnings; +no warnings 'redefine'; + +use Class::Struct; +use Visualization::NetworkGraph; +use Visualization::GML; +use SpeciesGraph; + + +struct RINF=> +{ + 'Nodes'=> '@', + 'Edges'=> '@', + +}; + +sub newRINF +{ + my $rinf = RINF->new(); + $rinf->{'Nodes'} = shift @_; + $rinf->{'Edges'} = shift @_; + return $rinf; +}; + +sub makeRINF +{ + my $bpg = shift @_; + my $model = shift @_; + my @allnodes = @{$bpg->{'NodeList'}}; + my %nodetype = %{$bpg->{'NodeType'}}; + my @rules = grep {$nodetype{$_} eq 'Rule'} @allnodes; + + + my %hash_of_vecs; + + foreach my $r(@rules) + { + $hash_of_vecs{$r} = getNeighbors($bpg->{'EdgeList'},$r); + } + + my @nodes = @rules; + my @edges; + + my %typehash = ("11"=>"Modulation","10"=>"Activation","01"=>"Inhibition"); + foreach my $i(0..@rules-2) + { + foreach my $j($i+1..@rules-1) + { + my $arr1 = $hash_of_vecs{$rules[$i]}; + my $arr2 = $hash_of_vecs{$rules[$j]}; + my @opts = ([0,0],[0,1],[0,2],[1,0],[1,1],[1,2],[2,0],[2,1],[2,2]); + # rule_i -> rule_j + # 0 (re,re), 1 (re,pr), 2 (re,co), + # 3 (pr,re), 4 (pr,pr), 5 (pr,co), + # 6 (co,re), 7 (co,pr),8 (co,co) + my @overlaps = map {my @opt = @$_; has_overlap($arr1->[$opt[0]],$arr2->[$opt[1]]); } @opts; + my $act = 0; my $inh = 0; + # i->j influence + $inh = ( $overlaps[0]==1 or $overlaps[2]==1) ? 1: 0; + $act = ( $overlaps[3]==1 or $overlaps[5]==1) ? 1: 0; + unless ($inh==0 and $act==0) + { + push @edges, join(":",($rules[$i],$rules[$j],$typehash{$act.$inh})); + } + + # j->i influence + $inh = ( $overlaps[0]==1 or $overlaps[6]==1) ? 1: 0; + $act = ( $overlaps[1]==1 or $overlaps[7]==1) ? 1: 0; + unless ($inh==0 and $act==0) + { + push @edges, join(":",($rules[$j],$rules[$i],$typehash{$act.$inh})); + } + } + #i->i influence + my $arr = $hash_of_vecs{$rules[$i]}; + my @opts = ([0,2],[1,2]); #re->co, pr->co + my @overlaps = map {my @opt = @$_; has_overlap($arr->[$opt[0]],$arr->[$opt[1]]); } @opts; + my $act = 0; my $inh = 0; + $act = ($overlaps[1]==1) ? 1 :0; + $inh = ($overlaps[0]==1) ? 1 :0; + unless ($inh==0 and $act==0) + { + push @edges, join(":",($rules[$i],$rules[$i],$typehash{$act.$inh})); + } + } + + my $rinf = newRINF(\@nodes,\@edges); + return $rinf; +} + +sub getNeighbors +{ + my $edgelist = shift @_; + my $rule = shift @_; + + sub getRel { + my $r = $_[0]; my $t = $_[1]; my @e = @{$_[2]}; + return sort map { $_ =~ /^.*:(.*):.*$/; $1 ; } + grep { $_ =~ /^.*:.*:(.*)$/; $1 eq $t; } + grep { $_ =~ /^(.*):.*:.*$/; $1 eq $r; } @e; + } + my @re = getRel($rule,'Reactant',$edgelist); + my @pr = getRel($rule,'Product',$edgelist); + my @co = getRel($rule,'Context',$edgelist); + return [\@re,\@pr,\@co]; +} +sub has_overlap +{ + my @x = @{shift @_}; + my @y = @{shift @_}; + my @z = grep {has(\@y,$_) } @x; + return (scalar(@z) > 0) ? 1: 0; +} + + +1; \ No newline at end of file diff --git a/libvcell/vcell_install/bionetgen/Perl2/Visualization/StructureGraph.pm b/libvcell/vcell_install/bionetgen/Perl2/Visualization/StructureGraph.pm new file mode 100644 index 0000000..cec5cc8 --- /dev/null +++ b/libvcell/vcell_install/bionetgen/Perl2/Visualization/StructureGraph.pm @@ -0,0 +1,661 @@ +package Viz; + +# pragmas +use strict; +use warnings; +# Perl Modules +use Class::Struct; +# BNG Modules +use SpeciesGraph; +#use Visualization::Viz; + +struct Node => +{ + 'Type' => '$', + #must be one of 'Mol', 'Comp', 'BondState', 'CompState', 'GraphOp', 'Rule' + 'Name' => '$', + 'ID' => '$', #only one id is used for each node + 'Parents' => '@', + 'Side' => '$', + 'Rule' => '$' +}; + +struct StructureGraph => { 'Type' => '$', 'NodeList' => '@' }; +# initializing methods +sub makeNode +{ + # input in this order Type, Name, ID, Parents, Side + # type and name are compulsory, rest are not + my $node = Node->new(); + $node->{'Type'} = shift @_; + $node->{'Name'} = shift @_; + $node->{'ID'} = @_ ? shift @_ : 0; + $node->{'Parents'} = @_ ? shift @_ : (); + $node->{'Side'} = @_ ? shift @_ : (); + return $node; +} + +sub makeStructureGraph +{ + # input is Type, NodeList + my $psg = StructureGraph->new(); + $psg->{'Type'} = $_[0]; + $psg->{'NodeList'} = $_[1]; + return $psg; +} +# print graph for sanity check +sub printNode +{ + my $node = $_; + my $string = $node->{'ID'}; + $string .= "\t\t"; + $string .= $node->{'Name'}; + if ($node->{'Parents'}) + { + $string .= "\t\t"; + $string .= "(".join(",",@{$node->{'Parents'}} ).")"; + } + + if ($node->{'Side'}) + { + $string .= "\t\t"; + $string .= $node->{'Side'}; + } + return $string; +} +sub printStructureGraph +{ + my $psg = shift @_; + my @string = map {printNode()} @{$psg->{'NodeList'}}; + return $psg->{'Type'}."\n".join("\n",@string); +} + +sub makePatternStructureGraph +{ + my $sg = shift @_; + my $index = @_ ? shift @_ : 0; # this is the index of the pattern in some list of patterns + + my @nodelist = (); + + if ( $sg->isNull() != 0) { return undef;} + + # Nodes for molecules, assigned the ID p.m, where p is the index of the pattern + # index must be passed to this method. + my $imol = 0; + foreach my $mol ( @{$sg->Molecules} ) + { + my $mol_id = $index.".".$imol; + push @nodelist, makeNode('Mol',$mol->Name,$mol_id); + + # Nodes for components, assigned the ID p.m.c + my $icomp = 0; + foreach my $comp( @{$mol->Components} ) + { + my $comp_id = $mol_id.".".$icomp; + my @parents = ($mol_id); + push @nodelist, makeNode('Comp',$comp->Name,$comp_id,\@parents); + + # Nodes for internal states, assigned the ID p.m.c.0 + if (defined $comp->State) + { + my $state_id = $comp_id.".0"; + my @parents = ($comp_id); + push @nodelist, makeNode('CompState',$comp->State,$state_id,\@parents); + } + + # Nodes for each wildcard bond (either !? or !+), assigned the ID p.m.c.1 + if (scalar @{$comp->Edges} > 0) + { + my $bond_state = ${$comp->Edges}[0]; + if ($bond_state =~ /^[\+\?]$/) + { + my $bond_id = $comp_id.".1"; + my @parents = ($comp_id); + push @nodelist, makeNode('BondState',$bond_state,$bond_id,\@parents); + } + } + $icomp++; + } + $imol++; + } + # Nodes for each specified bond, assigned the ID p.m1.c1.1, + # where m1.c1 and m2.c2 are the bonded components, sorted. + # specified bonds are all assigned the same name "+" + # only one id is used for each node + if (scalar @{$sg->Edges} > 0) + { + foreach my $edge (@{$sg->Edges}) + { + my @comps = sort split(/ /,$edge); + my $bond_id = $index.".".$comps[0].".1"; + my @parents = map {$index.".".$_} @comps; + push @nodelist, makeNode('BondState',"+",$bond_id,\@parents); + } + } + my $psg = makeStructureGraph('Pattern',\@nodelist); + #print $psg->printStructureGraph(); + return $psg; +} + +sub combine +{ +# appends an index to all nodes of each structure graph +# then combines the structure graphs + my @psg_list = @{shift @_}; + my $index = @_ ? shift @_ : "0"; + my $type = $psg_list[0]->{'Type'}; + my @nodelist = (); + + foreach my $i(0..@psg_list-1) + { + my $psg = $psg_list[$i]; + my @nodes = (); + if ($psg->{'NodeList'}) { push @nodes,@{$psg->{'NodeList'}} } ; + foreach my $node (@nodes) + { + my $id = $node->{'ID'}; + $node->{'ID'} = $index.".".$id; + if (defined $node->{'Parents'}) + { + my @parents_idlist = @{$node->{'Parents'}}; + my @parents_idlist_new = map {$index.".".$_} @parents_idlist; + $node->{'Parents'} = \@parents_idlist_new; + } + } + push @nodelist, @nodes; + } + my $psg1 = makeStructureGraph($type,\@nodelist); + return $psg1; +} +sub combine2 +{ +# trivially combines structure graphs + my @psg_list = @{shift @_}; + my $type = $psg_list[0]->{'Type'}; + my @nodelist = (); + + foreach my $i(0..@psg_list-1) + { + my $psg = $psg_list[$i]; + my @nodes; + if (defined $psg->{'NodeList'}) {@nodes = @{$psg->{'NodeList'}};} + if (@nodes) { push @nodelist, @nodes; } + } + my $psg1 = makeStructureGraph($type,\@nodelist); + return $psg1; +} + +sub hasType +{ + my @nodelist = @{shift @_}; + my $type = shift @_; + my @nodes = grep ( $_->{'Type'} eq $type, @nodelist); + return @nodes; +} +sub hasSide +{ + my @nodelist = @{shift @_}; + my $side = shift @_; + my @nodes = grep ( $_->{'Side'} eq $side, @nodelist); + return @nodes; +} +sub hasParent +{ + my @nodelist = @{shift @_}; + my $parent_id = shift @_; + my @nodes; + foreach my $node (@nodelist) + { + if ($node->{'Parents'}) + { + my @parents = @{$node->{'Parents'}}; + if (grep($_ eq $parent_id, @parents)) + {push @nodes, $node;} + } + } + return @nodes; +} + +sub hasParents +{ + my @nodelist = @{shift @_}; + my @parent_ids = @{shift @_}; + my @nodes; + @nodes = @nodelist; + foreach my $parent_id ( @parent_ids) + { + my @nodes2 = hasParent(\@nodes,$parent_id); + if (@nodes2) { @nodes = @nodes2; } + else { return (); } + } + return @nodes; +} +sub hasChildren +{ + my @nodelist = @{shift @_}; + my $node = shift @_; + my $id = $node->{'ID'}; + foreach my $n(@nodelist) + { + if ($n->{'Parents'}) + { + my @parents = @{$n->{'Parents'}}; + foreach my $p(@parents) + { + if ($p eq $id) { return 1;} + } + } + } + return 0; +} + +sub findNode +{ + my @nodelist = @{shift @_}; + my $idcheck = shift @_; + my @nodes = grep ($_->{'ID'} eq $idcheck,@nodelist); + if (@nodes) {return $nodes[0];} + return 0; +} +sub findNodes +{ + my @nodelist = @{shift @_}; + my @idlist = @{shift @_}; + my @nodes; + foreach my $idcheck(@idlist) + { + my $node = findNode(\@nodelist,$idcheck); + if ($node) { push @nodes, $node;} + } + return @nodes; +} + +# methods for rule structure graphs +sub makeRuleStructureGraph +{ + # Get rule reactants and products and map + my $rr = shift @_; + my $index = @_ ? shift @_ : "0"; + #my $name = @_ ? shift @_ : "0"; + my $name = $rr->Name; + + #print $rr->toString(); + my @reac = @{$rr->Reactants}; + my @prod= @{$rr->Products}; + my %mapf = %{$rr->MapF}; + my %mapr = %{$rr->MapR}; + + # the correspondence hash needs to be modified to add + # reactant/product indexes to IDs + %mapf = modifyCorrespondenceHash(\%mapf,0,1); + %mapr = modifyCorrespondenceHash(\%mapr,1,0); + + # Make combined structure graphs of reactant and product patterns respectively + my %ind_reac = indexHash(\@reac); + my %ind_prod = indexHash(\@prod); + + my @reac_psg = map( makePatternStructureGraph($_,$ind_reac{$_}), @reac); + my @prod_psg = map( makePatternStructureGraph($_,$ind_prod{$_}), @prod); + + my $reac_psg1 = combine(\@reac_psg,"0"); + my $prod_psg1 = combine(\@prod_psg,"1"); + + # the correspondence hash needs to be extended + # to include component states & bonds + my ($mapf1,$mapr1) = extendCorrespondenceHash(\%mapf,\%mapr,$reac_psg1,$prod_psg1); + %mapf = %$mapf1; + %mapr = %$mapr1; + + # merge the nodes to generate the 'implicit' rule structure graph + my $rsg = mergeCorrespondent(\%mapf,\%mapr,$reac_psg1,$prod_psg1); + + # add the graph operation nodes to generate + # the 'explicit' rule structure graph + $rsg = addGraphOperations($rsg); + $rsg = addRuleNode($rsg,$index,$name); + #print printStructureGraph($rsg); print "\n\n"; + return $rsg; +} +sub modifyCorrespondenceHash +{ + # modifying existing keys in place not recommended? + my %map = %{shift @_}; + my $ind1 = shift @_; + my $ind2 = shift @_; + my %map2; + + while ( my ($key,$value) = each %map) + { + my $key1 = $ind1.".".$key; + my $value1 = ($value eq "-1") ? -1 : $ind2.".".$value; + $map2{$key1} = $value1; + } + return %map2; +} +sub extendCorrespondenceHash +{ + my %mapf = %{shift @_}; + my %mapr = %{shift @_}; + + my $reac = shift @_; # should be a combined structure graph of patterns + my $prod = shift @_; + + my @reac_nodelist = @{$reac->{'NodeList'}}; + my @prod_nodelist = @{$prod->{'NodeList'}}; + + # filter the component states on both sides + # find the corresponding component on the other side + # see if it has a matching component state + + my @reac_compstates = hasType($reac->{'NodeList'},'CompState'); + my @prod_compstates = hasType($prod->{'NodeList'},'CompState'); + foreach my $node(@reac_compstates) + { + my $reac_id = $node->{'ID'}; + my $reac_parent = ${$node->{'Parents'}}[0]; + my $prod_parent = $mapf{$reac_parent}; + if ($mapf{$reac_parent} ne "-1") + { + my $prod_parent = $mapf{$reac_parent}; + my $prod_id = $prod_parent.".0"; + my $node2 = findNode(\@prod_compstates,$prod_id); + #$node2 always exists, because we check that $mapf{...} has not returned -1 + if ($node->{'Name'} eq $node2->{'Name'}) + { + $mapf{$reac_id} = $prod_id; + $mapr{$prod_id} = $reac_id; + } + } + } + + # filter the bond states on both sides + my @reac_bondstates = hasType($reac->{'NodeList'},'BondState'); + my @prod_bondstates = hasType($prod->{'NodeList'},'BondState'); + foreach my $node (@reac_bondstates) + { + my $reac_id = $node->{'ID'}; + my $name = $node->{'Name'}; + my @reac_parents = @{$node->{'Parents'}}; + if (scalar @reac_parents == 1) + { + my $reac_parent =$reac_parents[0]; + if ($mapf{$reac_parent} ne "-1") + { + my $prod_parent = $mapf{$reac_parent}; + my @node2 = hasParent(\@prod_bondstates,$prod_parent); + if (@node2 and $node2[0]->{'Name'} eq $name) + { + my $prod_id = $node2[0]->{'ID'}; + $mapf{$reac_id} = $prod_id; + $mapr{$prod_id} = $reac_id; + } + } + } + elsif (scalar @reac_parents == 2) + { + if ($mapf{$reac_parents[0]} ne "-1" and $mapf{$reac_parents[0]} ne "-1") + { + my @prod_parents = sort map ( $mapf{$_}, @reac_parents); + my @node2 = hasParents(\@prod_bondstates,\@prod_parents); + if (@node2 and $node2[0]->{'Name'} eq $name) + { + my $prod_id = $node2[0]->{'ID'}; + $mapf{$reac_id} = $prod_id; + $mapr{$prod_id} = $reac_id; + } + } + } + } + + # fill out the assignments for the remaining nodes that were not assigned + foreach my $node (@reac_nodelist) + { + if (! $mapf{$node->{'ID'}}) { $mapf{$node->{'ID'}} = "-1";} + } + foreach my $node (@prod_nodelist) + { + if (! $mapr{$node->{'ID'}}) { $mapr{$node->{'ID'}} = "-1";} + } + return (\%mapf,\%mapr); +} +sub mergeCorrespondent +{ + my %mapf = %{shift @_}; # these maps should have been modified and extended + my %mapr = %{shift @_}; + + my $reac = shift @_; # should be a combined structure graph of patterns + my $prod = shift @_; + + my @reac_nodelist = @{$reac->{'NodeList'}}; + my @prod_nodelist = @{$prod->{'NodeList'}}; + + # i.e. mapping correspondent IDs on both sides of a rule + # to a single canonical ID + my %idmap; + while (my ($key, $value) = each %mapf) + { + $idmap{$key} = $key; + } + while (my ($key, $value) = each %mapr) + { + $idmap{$key} = ($value eq "-1") ? $key : $value; + } + + my @nodelist = (); + + foreach my $node (@reac_nodelist) + { + #check if it has a correspondence + if ($mapf{$node->{'ID'}} ne "-1") + { + remapNode($node,\%idmap); + $node->{'Side'} = 'both'; + push @nodelist, $node; + } + else + { + remapNode($node,\%idmap); + $node->{'Side'} = 'left'; + push @nodelist, $node; + } + } + foreach my $node (@prod_nodelist) + { + if ($mapr{$node->{'ID'}} eq "-1") + { + remapNode($node,\%idmap); + $node->{'Side'} = 'right'; + push @nodelist, $node; + } + } + my $rsg = makeStructureGraph('Rule',\@nodelist); + return $rsg; +} +sub remapNode +{ + my $node = shift @_; + my %remap = %{shift @_}; + my $id = $node->{'ID'}; + $node->{'ID'} = $remap{$id}; + if ($node->{'Parents'}) + { + my @parents = @{$node->{'Parents'}}; + my @new_parents = sort map ( $remap{$_}, @parents); + $node->{'Parents'} = \@new_parents; + } + if (defined $node->{'Rule'}) + { + $node->{'Rule'} = $remap{$node->{'Rule'}}; + } +} +sub addGraphOperations +{ + my $rsg = shift @_; + my @nodelist = @{$rsg->{'NodeList'}}; + + my $id = -1; + + # identify modified bonds + my @bondstates = hasType(\@nodelist,'BondState'); + my @delbonds = hasSide(\@bondstates,'left'); + my @addbonds = hasSide(\@bondstates,'right'); + + my @mols = hasType(\@nodelist,'Mol'); + my @left_mols = hasSide(\@mols,'left'); + my @right_mols = hasSide(\@mols,'right'); + + my @compstates = hasType(\@nodelist,'CompState'); + my @left_compstates = hasSide(\@compstates,'left'); + my @right_compstates = hasSide(\@compstates,'right'); + + # transcribing the graph operations in order + # this order will be used later to process context + # order: ChangeState, deletebond/deletemol, addbond/addmol + + foreach my $left_compstate (@left_compstates) + { + # find the partner on the right + my $comp_id = ${$left_compstate->{'Parents'}}[0]; + my @partner = hasParent(\@right_compstates,$comp_id); + # partner may not exist, in case of deletion + if (@partner) + { + my $left_id = $left_compstate->{'ID'}; + my $right_id = $partner[0]->{'ID'}; + my $name = 'ChangeState'; + my @parents = ($left_id,$right_id); + push @nodelist, makeNode('GraphOp',$name,++$id,\@parents); + } + } + + foreach my $bondstate(@delbonds) + { + my $bond_id = $bondstate->{'ID'}; + my $name = 'DeleteBond'; + my @parents = ($bond_id); + push @nodelist, makeNode('GraphOp',$name,++$id,\@parents); + } + + foreach my $mol (@left_mols) + { + my $mol_id = $mol->{'ID'}; + my $name = 'DeleteMol'; + my @parents = ($mol_id); + push @nodelist, makeNode('GraphOp',$name,++$id,\@parents); + } + + foreach my $bondstate(@addbonds) + { + my $bond_id = $bondstate->{'ID'}; + my $name = 'AddBond'; + my @parents = ($bond_id); + push @nodelist, makeNode('GraphOp',$name,++$id,\@parents); + } + + foreach my $mol (@right_mols) + { + my $mol_id = $mol->{'ID'}; + my $name = 'AddMol'; + my @parents = ($mol_id); + push @nodelist, makeNode('GraphOp',$name,++$id,\@parents); + } + + my $rsg1 = makeStructureGraph('Rule',\@nodelist); + return $rsg1; +} +sub addRuleNode +{ + my $rsg = shift @_; + my $index = shift @_; + my $name = shift @_; + + my @nodelist = @{$rsg->{'NodeList'}}; + my %remap = map { $_->{'ID'} => $index.".".$_->{'ID'}} @nodelist; + + foreach my $node (@nodelist ) + { + remapNode($node,\%remap); + $node->{'Rule'} = $index; + } + my $node = makeNode('Rule',$name,$index); + $node->{'Rule'} = $index; + push @nodelist, $node; + my $rsg1 = makeStructureGraph('Rule',\@nodelist); + return $rsg1; +} +sub addPatternNode +{ + my $psg = shift @_; + my $index = shift @_; + my $prefix = shift @_; + my $name = @_ ? shift @_ : $prefix.$index; + my @nodelist = @{$psg->{'NodeList'}}; + my %remap = map { $_->{'ID'} => $index.".".$_->{'ID'}} @nodelist; + foreach my $node (@nodelist ) + { + remapNode($node,\%remap); + } + my $node = makeNode('Pattern',$name,$index); + foreach my $n(@nodelist) + { + if ($n->{'Type'} eq 'Mol') + { + @{$n->{'Parents'}} = ( $index ); + } + } + push @nodelist,$node; + my $psg1 = makeStructureGraph('Pattern',\@nodelist); + return $psg1; + +} + +# patter +# methods for rule pattern graphs +sub makeRulePatternGraph +{ + my $rr = shift @_; + my $index = shift @_; + my $name = $rr->Name; + my @reac = @{$rr->Reactants}; + my @prod= @{$rr->Products}; + + my @reac_psg = map ( makePatternStructureGraph($reac[$_],$_), 0..@reac-1); + my @prod_psg = map ( makePatternStructureGraph($prod[$_],$_), 0..@prod-1); + + # add species nodes + @reac_psg = map ( addPatternNode($reac_psg[$_],"0.".$_,"R"), 0..@reac_psg-1); + @prod_psg = map ( addPatternNode($prod_psg[$_],"1.".$_,"P"), 0..@prod_psg-1); + + # add rule node + my @psg = (@reac_psg,@prod_psg); + my $rbpg = combine2(\@psg); + $rbpg = addRuleNode($rbpg,$index,$name); + return $rbpg; +} + +sub makePatternClassGraph +{ + my @patstrs = @{shift @_}; + my $name = shift @_; + my $index = shift @_; + + my @psgs = map { stringToPatternStructureGraph($patstrs[$_],$_) } 0..@patstrs-1; + my $psg = combine(\@psgs,$index); + my $psg2 = addPatternNode($psg,$index,'',$name); + +} + +# string to pattern structure graph +sub stringToPatternStructureGraph +{ + my $pat = shift @_; + my $index = shift @_; + my $patstr = $pat; + my $sg = SpeciesGraph->new(); + my $err = SpeciesGraph::readString($sg,\$patstr); + my $psg = makePatternStructureGraph($sg,$index); + return $psg; +} + + +1; \ No newline at end of file diff --git a/libvcell/vcell_install/bionetgen/Perl2/Visualization/VisOptParse.pm b/libvcell/vcell_install/bionetgen/Perl2/Visualization/VisOptParse.pm new file mode 100644 index 0000000..972dc91 --- /dev/null +++ b/libvcell/vcell_install/bionetgen/Perl2/Visualization/VisOptParse.pm @@ -0,0 +1,175 @@ +package Viz; + +use strict; +use warnings; +no warnings 'redefine'; + + +sub parseOpts +{ + my $file = shift @_; + open FILE,$file or die "Cannot open file ".$file."\n"; + my @lines = ; + close FILE; + print "Processing Opts file ".$file."\n"; + @lines = clean(\@lines); + # parsing main block + my ($names,$arrs) = getblocks(\@lines,['background','classes','toggle','filter','inhibition','motifs']); + my %toggle; + #my %background = {'include'=>[],'exclude'=>[]}; + my %background; + my %classes; + my %filter; + my @inhibition; + my %motifs; + foreach my $i(0..@$names-1) + { + my $name = $names->[$i]; + my @arr = @{$arrs->[$i]}; + if ($name eq 'toggle') + { + my %opts = get_numericopts(\@arr); + optcheck(['background','groups','collapse','each'],[keys %opts]); + map { $toggle{$_} = $opts{$_} } keys %opts; + } + if ($name eq 'background') + { + my ($names2,$arrs2) = getblocks(\@arr,['include','exclude']); + foreach my $j(0..@$names2-1) + { + my $nm = $names2->[$j]; + my @ar = genlist($arrs2->[$j]); + $background{$nm} = \@ar; + } + } + if ($name eq 'classes') + { + my ($names2,$arrs2) = getblocks(\@arr); + foreach my $j(0..@$names2-1) + { + my $nm = $names2->[$j]; + my @ar = genlist($arrs2->[$j]); + $classes{$nm} = \@ar; + } + } + if ($name eq 'motifs') + { + my ($names2,$arrs2) = getblocks(\@arr); + foreach my $j(0..@$names2-1) + { + my $nm = $names2->[$j]; + my @ar = genlist($arrs2->[$j]); + $motifs{$nm} = \@ar; + } + } + if($name eq 'filter') + { + my @ar = genlist(\@arr); + $filter{'items'} =\@ar; + } + if($name eq 'inhibition') + { + @inhibition = genlist(\@arr); + } + + } + #print map { $_.":".join(",",@{$classes{$_}})."\n"; } keys %classes; + + return (\%toggle,\%background,\%classes,\%filter,\@inhibition,\%motifs); +} + +sub clean +{ + my @lines = @{shift @_}; + my @lines2; + foreach my $line(@lines) + { + # removing leading whitespace + $line =~ s/^\s+//g; + # removing trailing whitespace + $line =~ s/\s+$//g; + next if (length $line==0); + next if ($line =~ /^#/); + # compressing intermediate whitespace + $line =~ s/\s+/ /g; + push @lines2,$line; + } + return @lines2; +} + + +sub getblocks +{ + my @lines = @{shift @_}; + my @choices = @_ ? @{shift @_} : (); + my @names = (); + my @arrs = (); + my @arr = (); + my $blockname = ''; + my $err; + foreach my $line(@lines) + { + if ($line =~ /begin (.*)/ and $blockname eq '') + { + @arr = (); $blockname = $1; + if(@choices) + { + if(not has(\@choices,$blockname)) + { + $err = $blockname." not recognized as a block name."; + } + } + next; + } + + if ($line eq 'end '.$blockname) + { + my @arr2 = @arr; + push @arrs,\@arr2; + push @names,$blockname; + $blockname = ''; + next; + } + push @arr, $line; + } + if($blockname ne '') + { $err = "Problem reading block ".$blockname."."; } + if($err) { print "Error: ".$err."\n"; exit; } + #foreach my $i(0..@names-1) + # { print $names[$i].":".join(",",@{$arrs[$i]})."\n";} + return (\@names,\@arrs); +} + +sub genlist +{ + return split(" ",join(" ",@{shift @_})); +} +sub optcheck +{ + my $standard = shift @_; + my $checkthis = shift @_; + + foreach my $x(@$checkthis) + { + if(not has($standard,$x)) + { + print $x." is not a valid option."; + print "Valid options are ".join(",",@$standard)."\n"; + exit; + } + } + return; +} + +sub get_numericopts +{ + my @lines = @{shift @_}; + my %opts; + foreach my $line(@lines) + { + $line =~ /(.*)\s(.*)/; + $opts{$1} = $2; + } + return %opts; +} +1; \ No newline at end of file diff --git a/libvcell/vcell_install/bionetgen/Perl2/Visualization/Viz.pm b/libvcell/vcell_install/bionetgen/Perl2/Visualization/Viz.pm new file mode 100644 index 0000000..db53a5c --- /dev/null +++ b/libvcell/vcell_install/bionetgen/Perl2/Visualization/Viz.pm @@ -0,0 +1,1813 @@ +package Viz; + +use strict; +use warnings; +no warnings 'redefine'; + +use Class::Struct; +use SpeciesGraph; +use Visualization::StructureGraph; +use Visualization::NetworkGraph; +use Visualization::ProcessGraph; +use Visualization::ContactMap; +use Visualization::GML; +use Visualization::RINF; +#use Visualization::DB; + + +struct Graphs => +{ + 'RuleNames' => '@', + 'RuleStructureGraphs' => '@', + 'RulePatternGraphs' => '@', + 'RuleNetwork' => '$', + 'RuleNetworkCurrent' => '$', + 'ContactMap' => '$', + 'Background' => '@', # array of atomic patterns + 'Classes' => '%', # classname => \@arrayofnodes + 'NewName' => '$', # just a number to keep track of generated new names +}; + +sub uniq { my %seen = (); grep { not $seen{$_}++ } @_; } +sub has { scalar grep ( $_ eq $_[1], @{$_[0]}); } +sub flat { map @$_, @_; } +sub unquotemeta(;$) { + my ($string) = scalar(@_) ? $_[0] : $_; # quotemeta() "If EXPR is omitted, uses $_." + return '' if !defined $string; # quotemeta() undef behavior + + $string =~ s/(?:\\(?!\\))//g; + $string =~ s/(?:\\\\)/\\/g; + + return $string; +} + +sub uniqadd { if (not has($_[0],$_[1]) ) {push @{$_[0]}, $_[1] ; }} +sub indexHash +{ + my @x = @{$_[0]}; + map { $x[$_]=>$_ } 0..@x-1; +} + +sub push2ref +{ + my $arr = shift @_; + my $item = shift @_; + if(ref $item) { push @$arr,@$item; } + else { push @$arr,$item; } + return; +} + +########################## +sub initializeExecParams +{ + my $toggle1 = 1; + + my @include = (); + my @exclude = (); + my $background = {'toggle'=>$toggle1,'include'=>\@include,'exclude'=>\@exclude}; + my $each = 0; + my $groups = 0; + my $embed = 0; + my $classes = {}; + + my $toggle2 = 0; + my @items = (); + my $level = 1; + my $filter = {'toggle'=>$toggle2,'items'=>\@items,'level'=>$level}; + + my @inhibition = (); + my %motifs = (); + my %x = ('background'=>$background,'each'=>$each,'groups'=>$groups,'classes'=>$classes,'filter'=>$filter,'embed'=>0,'inhibition'=>\@inhibition,'motifs'=>\%motifs); + + return %x; + +} + +sub getExecParams +{ + my %args = %{shift @_}; + my %exec_params = initializeExecParams(); + my %toggle; + my %background; + my %classes; + #print "\nARGKEYS ".join(" ",keys %args)."\n"; + foreach my $file(@{$args{'opts'}}) + { + my ($x,$y,$z,$f,$inh,$mot) = parseOpts($file); + my %toggle = %$x; + my %background = %$y; + my %classes = %$z; + my %filter = %$f; + my @inhibition= @$inh; + my %motifs = %$mot; + # do toggles; + foreach my $key(keys %toggle) + { + if($key eq 'background') + { $exec_params{'background'}->{'toggle'} = $toggle{$key}; } + + if(has(['each','groups'],$key)) + { $exec_params{$key} = $toggle{$key}; } + } + # do background + foreach my $key(keys %background) + { + my $ref = $exec_params{'background'}->{$key}; + push2ref($ref,$background{$key}); + } + foreach my $key(keys %classes) + { + my $classes2 = $exec_params{'classes'}; + my @arr = (); + if(not defined $classes2->{$key}) { $classes2->{$key} = \@arr; } + push2ref($classes2->{$key},$classes{$key}); + } + if(defined $filter{'items'}) + { + if (not defined $exec_params{'filter'}->{'items'}) {$exec_params{'filter'}->{'items'} = [];}; + push2ref($exec_params{'filter'}->{'items'},$filter{'items'}); + } + if(@inhibition) + { + push2ref($exec_params{'inhibition'},\@inhibition); + } + + foreach my $key(keys %motifs) + { + my $motifs2 = $exec_params{'motifs'}; + my @arr = (); + if(not defined $motifs2->{$key}) { $motifs2->{$key} = \@arr; } + push2ref($motifs2->{$key},$motifs{$key}); + } + + } + + # AS2021 - adding output types + if(defined $args{'outType'}) { + $exec_params{'outType'} = $args{'outType'}; + } else { + # default to graphml + $exec_params{'outType'} = 'graphml'; + } + + $exec_params{'type'} = $args{'type'}; + $exec_params{'background'}->{'toggle'} = $args{'background'}; + $exec_params{'filter'}->{'toggle'} = $args{'filter'}; + $exec_params{'each'} = $args{'each'}; + $exec_params{'groups'} = $args{'groups'}; + $exec_params{'collapse'} = $args{'collapse'}; + $exec_params{'textonly'} = $args{'textonly'}; + $exec_params{'suffix'} = $args{'suffix'}; + $exec_params{'mergepairs'} = $args{'mergepairs'}; + $exec_params{'embed'} = $args{'embed'}; + + + if(defined $args{'level'}) { $exec_params{'filter'}->{'level'} = $args{'level'} }; + if(defined $args{'reset'}) { $exec_params{'reset'} = $args{'reset'} }; + if(defined $args{'ruleNames'}) { $exec_params{'ruleNames'} = $args{'ruleNames'} }; + + # pass along remaining parameters + if(defined $args{'doNotUseContextWhenGrouping'}) { $exec_params{'doNotUseContextWhenGrouping'} = $args{'doNotUseContextWhenGrouping'}; } + if(defined $args{'removeReactantContext'}) { $exec_params{'removeReactantContext'} = $args{'removeReactantContext'}; } + if(defined $args{'makeInhibitionEdges'}) { $exec_params{'makeInhibitionEdges'} = $args{'makeInhibitionEdges'}; } + if(defined $args{'removeProcessNodes'}) { $exec_params{'removeProcessNodes'} = $args{'removeProcessNodes'}; } + if(defined $args{'compressRuleMotifs'}) { $exec_params{'compressRuleMotifs'} = $args{'compressRuleMotifs'}; } + if(defined $args{'doNotCollapseEdges'}) { $exec_params{'doNotCollapseEdges'} = $args{'doNotCollapseEdges'}; } + + if(defined $args{'inhibition'}) { $exec_params{'inhibition'} = $args{'inhibition'}; } + if(defined $args{'motifs'}) {$exec_params{'motifs'} = $args{'motifs'}}; + + return \%exec_params; +} +########################## + +sub execute_params +{ + my $model = shift @_; + my %args = %{shift @_}; + + my @argkeys = keys %args; + + #print "\n".join(" ",@argkeys)."\n"; + my $err = ''; #"visualize() error."; + + $args{'output'} = 1 if (not has(\@argkeys,'output')); + if($args{'output'} == 1) {print "Executing visualize() command.\n"; } + $args{'suffix'} = '' if (not has(\@argkeys,'suffix')); + $args{'each'} = 0 if (not has(\@argkeys,'each')); + $args{'groups'} = 0 if (not has(\@argkeys,'groups')); + $args{'collapse'} = 0 if (not has(\@argkeys,'collapse')); + #$args{'filter'} = {'items'=>[],} if (not has(\@argkeys,'collapse')); + $args{'textonly'} = 0 if (not has(\@argkeys,'textonly')); + $args{'embed'} = 0 if(not has(\@argkeys,'embed')); + $args{'classes'} = {} if (not has(\@argkeys,'classes')); + + $args{'background'} = {} if (not has(\@argkeys,'background')); + my @argkeys2 = keys %{$args{'background'}}; + $args{'background'}->{'toggle'} = 1 if(not has(\@argkeys2,'toggle')); + $args{'background'}->{'include'} = [] if(not has(\@argkeys2,'include')); + $args{'background'}->{'exclude'} = [] if(not has(\@argkeys2,'exclude')); + + $args{'reset'} = 0 if(not has (\@argkeys,'reset')); + $args{'ruleNames'} = 0 if(not has (\@argkeys,'ruleNames')); + $args{'doNotUseContextWhenGrouping'} = 0 if(not has(\@argkeys,'doNotUseContextWhenGrouping')); + $args{'removeReactantContext'} = 0 if(not has(\@argkeys,'removeReactantContext')); + $args{'makeInhibitionEdges'} = 0 if(not has(\@argkeys,'makeInhibitionEdges')); + $args{'removeProcessNodes'} = 0 if(not has(\@argkeys,'removeProcessNodes')); + $args{'inhibition'} = [] if(not has(\@argkeys,'inhibition')); + $args{'motifs'} = {} if(not has(\@argkeys,'motifs')); + $args{'compressRuleMotifs'} = 0 if (not has(\@argkeys,'compressRuleMotifs')); + $args{'doNotCollapseEdges'} = 0 if (not has(\@argkeys,'doNotCollapseEdges')); + + #my @validtypes = qw (rule_pattern rule_operation rule_network reaction_network transformation_network contact process processpair ); + my @validtypes = qw (ruleviz_pattern ruleviz_operation regulatory reaction_network contactmap process rinf opts); + + # simplifying input types + push @validtypes, qw(conventional compact); + + if (not has(\@argkeys,'type')) + { + $err = "Visualization type unspecified. Use visualize({type=>\"string\"}),\n"; + $err .= "string being one of ("; + foreach my $v (@validtypes){ + $err .= " $v"; + } + $err .= " )."; + return $err; + } + + if (not has(\@validtypes,$args{'type'}) ) + { + $err = "Visualization error: '" . $args{'type'} . "' is an invalid type.\n"; + return $err; + } + + my $type = $args{'type'}; + # simplifying type inputs, aliasing to existing types + if( $args{'type'} eq 'conventional') { $type = 'ruleviz_pattern';} + if( $args{'type'} eq 'compact') { $type = 'ruleviz_operation';} + + # AS2021 - adding output types + my $outType = $args{'outType'}; + + my $output = $args{'output'}; + my $each = $args{'each'}; + my $groups = $args{'groups'}; + my $background = $args{'background'}; + my $except = $args{'except'}; + my $collapse = $args{'collapse'}; + my $filter = $args{'filter'}; + my $textonly = $args{'textonly'}; + my $suffix = $args{'suffix'}; + my %classdefs = %{$args{'classes'}}; + my $embed = $args{'embed'}; + + my $bkg = $args{'background'}; + my $bkg_toggle = $bkg->{'toggle'}; + my $bkg_include = $bkg->{'include'}; + my $bkg_exclude = $bkg->{'exclude'}; + + my $inhibition = $args{'inhibition'}; + my $motifs = $args{'motifs'}; + + my $reset = $args{'reset'}; + + #my $closed = $args{'closed'}; + + my @includes = (); + my $ref1 = getAtomicPatterns($bkg_include); + if(not ref $ref1) { + $err = "Atomic Pattern could not be created from ".$ref1."\n"."An atomic pattern is either \n\tA binding site, e.g. A(b),\n\tAn internal state, e.g. A(b~x),\n\tA bond, e.g. A(b!1).B(a!1), or\n\tA molecule, e.g. A.\n"; + return $err; + } + else {@includes = @$ref1}; + + my @excludes = (); + my $ref2 = getAtomicPatterns($bkg_exclude); + if(not ref $ref2) { + $err = "Atomic Pattern could not be created from ".$ref2."\n"."An atomic pattern is either \n\tA binding site, e.g. A(b),\n\tAn internal state, e.g. A(b~x),\n\tA bond, e.g. A(b!1).B(a!1), or\n\tA molecule, e.g. A.\n"; + return $err; + } + else {@excludes = @$ref2}; + + my %classes; + foreach my $name(keys %classdefs) + { + # we're converting class1:[item1,item2] to the form item1:class1, item2:class1 + my $ref = getAtomicPatterns($classdefs{$name}); + if(not ref $ref) { + $err = "Atomic Pattern could not be created from ".$ref."\n"."An atomic pattern is either \n\tA binding site, e.g. A(b),\n\tAn internal state, e.g. A(b~x),\n\tA bond, e.g. A(b!1).B(a!1), or\n\tA molecule, e.g. A.\n"; + return $err; + } + else {@classes {@$ref} = ($name) x @$ref; } + } + + if (not defined $model->VizGraphs) + { + my $gr = Graphs->new(); + $model->VizGraphs($gr); + $gr->{'NewName'} = -1; + } + + my $gr = $model->VizGraphs; + my @rrules = @{$model->RxnRules}; + my $str = ''; + my @strs = (); + my @groups; + + getRuleNames($model); + + if($type eq 'opts') + { + getRuleNetwork($model); + my $bpg = $model->VizGraphs->{'RuleNetwork'}; + my $mtypes = $model->MoleculeTypesList->MolTypes; + $str = writeExampleOpts($bpg,$mtypes); + } + + if($type eq 'rinf') + { + getRuleNetwork($model); + my $bpg = $gr->{'RuleNetwork'}; + my $rinf = makeRINF($bpg,$model); + # AS2021 - adding output types + $str = toGML_rinf($rinf,$outType); + } + if ($type eq 'ruleviz_operation') + { + getRuleStructureGraphs($model); + if($output==1 and $each==0) + { + my @rsgs = map {@$_;} flat($gr->{'RuleStructureGraphs'}); + my $rsg = combine2(\@rsgs); + #print printStructureGraph($rsg); + # AS2021 - adding output types + $str = toGML_rule_operation($rsg,$outType); + } + if($output==1 and $each==1 and $groups==0) + { + my @rsgs = map {@$_;} flat($gr->{'RuleStructureGraphs'}); + foreach my $rsg(@rsgs) + { + # AS2021 - adding output types + $str = toGML_rule_operation($rsg,$outType); + push @strs,$str; + } + } + } + + + if ($type eq 'ruleviz_pattern') + { + getRulePatternGraphs($model); + if($output==1 and $each==0) + { + my @rsgs = map {@$_;} flat($gr->{'RulePatternGraphs'}); + my $rsg = combine2(\@rsgs); + #print printStructureGraph($rsg); + # AS2021 - adding output types + $str = toGML_rule_pattern($rsg,$outType); + } + if($output==1 and $each==1 and $groups==0) + { + my @rsgs = map {@$_;} flat($gr->{'RulePatternGraphs'}); + foreach my $rsg(@rsgs) + { + # AS2021 - adding output types + $str = toGML_rule_pattern($rsg,$outType); + push @strs,$str; + } + } + } + + if ($type eq 'contactmap') + { + getContactMap($model); + if($output==1) + { + # AS2021 - adding output types + my $str = toGML_pattern($gr->{'ContactMap'},$outType); + my $suffix = $args{'suffix'}; + my %params = ('model'=>$model,'str'=>$str,'suffix'=>$suffix,'type'=>$type,'outType'=>$outType); + writeGML(\%params); + return; + + } + } + + if ($type eq 'regulatory') + { + # printing rule network (using each or without each) + getRuleNetwork($model); + applyRuleNetworkCurrent($model,$model->VizGraphs->{'RuleNetwork'}); + if($reset==1) + { + applyRuleNetworkCurrent($model,$model->VizGraphs->{'RuleNetwork'}); + undef $model->VizGraphs->{'Background'}; + undef $model->VizGraphs->{'Classes'}; + } + if ($each==0) + { + if ($filter->{'toggle'}==1 and defined $filter->{'items'}) + { + my $bpg = $gr->{'RuleNetworkCurrent'}; + my @items= @{$filter->{'items'}}; + my $level = $filter->{'level'}; + print "Filtering network based on user-provided list.\n"; + $bpg = filterNetworkGraphByList($bpg,\@items,$level); + applyRuleNetworkCurrent($model,$bpg); + } + + my $remap_pairs = []; + if($args{'compressRuleMotifs'} == 1) + { + # Compressing motifs of rules (i.e. groups of rules that form a motif) + # This is performed BEFORE Background Removal + # IT IS PERMANENT AND IRREVERSIBLE + my $bpg = $gr->{'RuleNetworkCurrent'}; + print "Compressing defined motifs of rules.\n"; + ($bpg,$remap_pairs) = compressRuleMotifs($bpg,$args{'motifs'}); + applyRuleNetworkCurrent($model,$bpg); + } + if ($bkg_toggle==0) + { + my $bpg = $gr->{'RuleNetworkCurrent'}; + getBackground($model,\@includes,\@excludes,$bpg); + print "Filtering background.\n"; + $bpg = filterNetworkGraph($bpg,$gr->{'Background'}); + applyRuleNetworkCurrent($model,$bpg); + } + + if ($groups==1) + { + my $bpg = $gr->{'RuleNetworkCurrent'}; + print "Creating classes of atomic patterns and rules.\n"; + syncClasses($model,$bpg,\%classes,$args{'doNotUseContextWhenGrouping'}); + applyRuleNetworkCurrent($model,$bpg); + } + if($args{'removeReactantContext'} ==1) + { + ##### THIS IS AN AESTHETIC MOD, i.e. IT HAS NO EFFECT ON GROUPING + #### IT IS PERFORMED AFTER GROUPING, BUT BEFORE COLLAPSING + my $bpg = $gr->{'RuleNetworkCurrent'}; + print "Removing redundant context from reactants.\n"; + $bpg = removeReactantContext($bpg); + applyRuleNetworkCurrent($model,$bpg); + } + if($args{'makeInhibitionEdges'} ==1) + { + ##### THIS IS AN AESTHETIC MOD, i.e. IT HAS NO EFFECT ON GROUPING + #### IT IS PERFORMED AFTER GROUPING, BUT BEFORE COLLAPSING + my $bpg = $gr->{'RuleNetworkCurrent'}; + print "Making inhibition edges.\n"; + $bpg = makeInhibitionEdges($bpg,$inhibition,$remap_pairs); + applyRuleNetworkCurrent($model,$bpg); + } + + if($groups==1 and $collapse==1) + { + my $bpg = $gr->{'RuleNetworkCurrent'}; + print "Collapsing network graph using equivalence classes.\n"; + $bpg = collapseNetworkGraph($bpg,$args{'doNotCollapseEdges'}); + applyRuleNetworkCurrent($model,$bpg); + } + + if($output==1) + { + my $bpg = $gr->{'RuleNetworkCurrent'}; + if ($textonly==1) + { + $str = printNetworkGraph($bpg); + $output = 0; + } + else + { + # AS2021 - adding output types + $str = toGML_rule_network($bpg,$embed,$args{'ruleNames'},$outType); + } + } + } + if ($each ==1) + { + my %args2 = duplicate_args(\%args); + $args2{'output'} = 0; + $args2{'each'} = 0; + $args2{'collapse'} = 0; + execute_params($model,\%args2); + my $bpg = $model->VizGraphs->{'RuleNetworkCurrent'}; + my %classes = ($groups==1) ? %{$bpg->{'NodeClass'}} : (); + my %nodetype = %{$bpg->{'NodeType'}}; + my @edges = @{$bpg->{'EdgeList'}}; + my @wcs = uniq(map {$_ =~ /^(.*):.*:.*/; $1; } grep /Wildcard/,@edges); + my @groups = uniq map {$classes{$_}} + grep {has([keys %classes],$_)} + grep {$nodetype{$_} eq 'Rule'} + @{$bpg->{'NodeList'}}; + + # classed rules + foreach my $i(0..@groups-1) + { + my $grpname = $groups[$i]; + # check if group is for rules or aps; + my @grp = grep { $classes{$_} eq $grpname } keys %classes; + my $grptype = $nodetype{$grp[0]}; + my $bpg2 = filterNetworkGraphByList($bpg,\@grp,1); + # AS2021 - adding output types + my $str = ($textonly==1) ? printNetworkGraph($bpg2) : toGML_rule_network($bpg2,$embed,$args{'ruleNames'},$outType); + my %params = ('model'=>$model,'str'=>$str,'suffix'=>($suffix ? $suffix.'_'.$grpname : $grpname),'type'=>$type,'outType'=>$outType); + if($output==1) + { + if($textonly==1) { writeText(\%params); } + else { writeGML(\%params); } + } + } + # unclassed rules + my @unclassed_rules = grep { not has([keys %classes],$_) } + grep {$nodetype{$_} eq 'Rule'} + @{$bpg->{'NodeList'}}; + foreach my $i(0..@unclassed_rules-1) + { + my @grp = ($unclassed_rules[$i]); + my $bpg2 = filterNetworkGraphByList($bpg,\@grp,1); + # right now this is not efficient + # better way is to regenerate the network graph, but then u'll have to apply background n + # filter n other things again... boring! + my $str = ($textonly==1) ? printNetworkGraph($bpg2) : toGML_rule_network($bpg2,$embed,$args{'ruleNames'},$outType); + my %params = ('model'=>$model,'str'=>$str,'suffix'=>($suffix ? $suffix.'_'.$grp[0] : $grp[0]),'type'=>$type,'outType'=>$outType); + if($output==1) + { + if($textonly==1) { writeText(\%params); } + else { writeGML(\%params); } + } + } + } + + + if($each==1) {$output = 0;} + } + + # + #if($type eq 'regulatory_db') + #{ + # my %args2 = duplicate_args(\%args); + # $args2{'type'} = 'regulatory'; + # $args2{'output'} = 0; + # $args2{'groups'} = 0; + # $args2{'collapse'} = 0; + # $args{'background'}->{'toggle'} = 1; + # execute_params($model,\%args2); + # my $bpg = $model->VizGraphs->{'RuleNetworkCurrent'}; + # my $prefix = $model->getOutputPrefix(); + # my $name = $prefix.".db"; + # my $dbh = newDBFile($name); + # $dbh = getRegDB($dbh,$bpg); + # $dbh = getRuleDB($dbh,$model->RxnRules); + # $dbh->disconnect(); + # print "Writing regulatory graph database as $name\nDone!\n"; + # print "To modify background and grouping, run: sqlite3 $name.\n"; + # print "To generate the regulatory graph, run: visualize.pl --db $name [--background] [--groups [--collapse]]\n"; + # exit; + #} + + + + if($type eq 'process') + { + my %args2 = duplicate_args(\%args); + $args2{'type'} = 'regulatory'; + $args2{'output'} = 0; + #$args2{'groups'} = 0; + $args2{'collapse'} = 0; + #$args2{'embed'} = 0; + #if($args{'mergepairs'}) {$args2{'groups'}=1;$args{'groups'}=1;} + #if($args{'groups'}) { $args2{'collapse'}=1; } + execute_params($model,\%args2); + my $bpg = $model->VizGraphs->{'RuleNetworkCurrent'}; + + my $pg = makeProcessGraph2($bpg,\%args); + + if($args{'embed'}==1) {embedProcessGraph($pg,$gr,\%args);} + if($output==1) + { + if($textonly==1) {$str = printProcessGraph($pg); } + # AS2021 - adding output types + else { $str = toGML_process2($pg,$outType); } + } + } + + if($type eq 'reaction_network') + { + $BNGModel::GLOBAL_MODEL = $model; + if(-e $model.".net") + { + my $err = $model->readNetwork({file=>$model.".net"}); + print @{$model->RxnList->Array}; + } + else + { + my $err = $model->generate_network({write=>0,TextReaction=>1}); + } + my @bpgs = map {makeRxnNetworkGraph($_)} @{$model->RxnList->Array}; + my $bpg = mergeNetworkGraphs(flat(\@bpgs)); + $bpg->{'Merged'} = 1; + # AS2021 - adding output types + $str = toGML_rule_network($bpg,$args{'ruleNames'},$outType); + } + + + if(( ($textonly==1) or ($type eq 'opts') ) and $each==0) + { + my %params = ('model'=>$model,'str'=>$str,'suffix'=>$suffix,'type'=>$type,'argstype'=>$args{'type'}); + writeText(\%params); + $output=0; + } + + if ($output==1 and $each==0) + { + my $suffix = $args{'suffix'}; + my %params = ('model'=>$model,'str'=>$str,'suffix'=>$suffix,'type'=>$type,'groups'=>$groups,'argstype'=>$args{'type'},'outType'=>$outType); + writeGML(\%params); + } + + if ($output==1 and $each==1 and $groups==0) + { + my @names = map {@$_;} flat($gr->{'RuleNames'}); + map { + my %params = ('model'=>$model,'str'=>$strs[$_],'suffix'=>($suffix ? $suffix.'_'.$names[$_] : $names[$_]),'type'=>$type,'argstype'=>$args{'type'},'outType'=>$outType); + writeGML(\%params); + } (0..@names-1); + } + + + return ''; +} + +sub writeText +{ + my %params = %{shift @_}; + my $model = $params{'model'}; + my $str = $params{'str'}; + my $prefix = $model->getOutputPrefix(); + my $type = $params{'type'}; + my $argstype = (defined $params{'argstype'}) ? $params{'argstype'} : $type; + my $suffix = (defined $params{'suffix'}) ? $params{'suffix'} : ''; + + my %outputstr = ( 'rule_operation' => 'rule(s) with graph operations', + 'rule_pattern' => 'rule(s) with patterns', + 'regulatory' => 'network of rules and atomic patterns', + 'patterns' => 'atomic patterns', + 'opts' => 'example options file'); + my $outputmsg = $outputstr{$type}; + + my $file = ''; + $file .= $prefix; + #$file .= "_".$type; + $file .= "_".$params{'argstype'}; + $file .= "_".$suffix if (length $suffix > 0); + $file .= ".txt"; + + # write the string to file + my $FH; + open($FH, '>', $file) or return "Couldn't write to $file: $!\n"; + print $FH $str; + close $FH; + + # all done + + print sprintf( "Wrote %s in TXT format to %s.\n", $outputmsg, $file); + return undef; +} + +sub writeGML +{ + my %params = %{shift @_}; + my $model = $params{'model'}; + my $str = $params{'str'}; + my $prefix = $model->getOutputPrefix(); + my $type = $params{'type'}; + my $argstype = (defined $params{'argstype'}) ? $params{'argstype'} : $type; + my $suffix = (defined $params{'suffix'}) ? $params{'suffix'} : ''; + my $outType = (defined $params{'outType'}) ? $params{'outType'} : 'graphml'; + + my %outputstr = ( 'ruleviz_operation' => 'rule(s) with graph operations', + 'ruleviz_pattern' => 'rule(s) with patterns', + 'regulatory' => 'network of rules and atomic patterns', + 'process' => 'process graph of rules', + 'contactmap' => 'contact map of model', + 'reaction_network' => 'reaction network of model', + 'rinf' => 'rule influence diagram of model', + 'opts' => 'example options file for regulatory graph of model' + ); + my $outputmsg = $outputstr{$type}; + + my $file = ''; + $file .= $prefix; + #$file .= "_".$type; + $file .= "_".$argstype; + $file .= "_".$suffix if (length $suffix > 0); + if ($outType eq 'gml') { + $file .= ".gml"; + } else { + $file .= ".graphml"; + } + + + # write the string to file + my $FH; + open($FH, '>', $file) or return "Couldn't write to $file: $!\n"; + print $FH $str; + close $FH; + + # all done + print sprintf( "Wrote %s in %s format to %s.\n", $outputmsg, $outType, $file); + return undef; +} + +sub writeGML2 +{ + my %params = %{shift @_}; + my $str = $params{'str'}; + my $prefix = $params{'prefix'}; + my $type = $params{'type'}; + my $suffix = (defined $params{'suffix'}) ? $params{'suffix'} : ''; + my $outType = (defined $params{'outType'}) ? $params{'outType'} : 'graphml'; + + my %outputstr = ( 'ruleviz_operation' => 'rule(s) with graph operations', + 'ruleviz_pattern' => 'rule(s) with patterns', + 'regulatory' => 'network of rules and atomic patterns', + 'process' => 'process graph of rules', + 'contactmap' => 'contact map of model' + ); + my $outputmsg = $outputstr{$type}; + + my $file = ''; + $file .= $prefix; + $file .= "_".$type; + $file .= "_".$suffix if (length $suffix > 0); + if ($outType eq 'gml') { + $file .= ".gml"; + } else { + $file .= ".graphml"; + } + + # write the string to file + my $FH; + open($FH, '>', $file) or return "Couldn't write to $file: $!\n"; + print $FH $str; + close $FH; + + # all done + print sprintf( "Wrote %s in %s format to %s.\n", $outputmsg, $outType, $file); + return undef; +} + +# get methods for different graphs +sub getRuleNames +{ + my $model = shift @_; + my $gr = $model->VizGraphs; + if(not defined $gr->{'RuleNames'}) + { + my @rrules = @{$model->RxnRules}; + my @names_arr = (); + foreach my $rrule(@rrules) + { + my @names = map {$_->Name;} @$rrule; + push @names_arr,\@names; + } + $gr->{'RuleNames'} = \@names_arr; + } + return; +} +sub getRuleStructureGraphs +{ + my $model = shift @_; + my $gr = $model->VizGraphs; + if (not defined $gr->{'RuleStructureGraphs'}) + { + my @rrules = @{$model->RxnRules}; + my @rsgs_arr = (); + my @names_arr = (); + my $j = 0; + foreach my $i(0..@rrules-1) + { + my @rrule = @{$rrules[$i]}; + my @rsgs = map makeRuleStructureGraph($_,$j++), @rrule; + push @rsgs_arr, \@rsgs; + } + $gr->{'RuleStructureGraphs'} = \@rsgs_arr; + } + return; +} +sub getRulePatternGraphs +{ + my $model = shift @_; + my $gr = $model->VizGraphs; + + if (not defined $gr->{'RulePatternGraphs'}) + { + my @rrules = @{$model->RxnRules}; + my @rsgs_arr = (); + my $j = 0; + foreach my $i(0..@rrules-1) + { + my @rrule = @{$rrules[$i]}; + my @rsgs = map makeRulePatternGraph($_,$j++), @rrule; + push @rsgs_arr, \@rsgs; + } + $gr->{'RulePatternGraphs'} = \@rsgs_arr; + } + return; +} +sub getRuleNetworkGraphs +{ + my $model = shift @_; + my $gr = $model->VizGraphs; + getRuleStructureGraphs($model); + if (not defined $gr->{'RuleNetworkGraphs'}) + { + print "Building network graphs for individual rules.\n"; + my @rsgs_arr = @{$gr->{'RuleStructureGraphs'}}; + my @names_arr = @{$gr->{'RuleNames'}}; + my @bpgs_arr = (); + foreach my $i(0..@rsgs_arr-1) + { + my @names = @{$names_arr[$i]}; + my @rsgs = @{$rsgs_arr[$i]}; + my @bpgs; + foreach my $j(0..@rsgs-1) + { + my $bpg = makeRuleNetworkGraph($rsgs[$j],$names[$j]); + push @bpgs, $bpg; + } + push @bpgs_arr,\@bpgs; + } + $gr->{'RuleNetworkGraphs'} = \@bpgs_arr; + } + return; +} +sub getRuleNetwork +{ + #my ($model,$groups,$background,$excepts,$classes) = @_; + my $model = shift @_; + my $gr = $model->VizGraphs; + getRuleNetworkGraphs($model); + my $bpg; + if (not defined $gr->{'RuleNetwork'}) + { + print "Compiling network graph for whole model.\n"; + $bpg = mergeNetworkGraphs(flat(@{$gr->{'RuleNetworkGraphs'}})); + $bpg = resolveWildcards($bpg); + $bpg->{'Merged'} = 1; + $bpg->{'Collapsed'} = 0; + $gr->{'RuleNetwork'} = $bpg; + } + return; +} + + +sub getContactMap +{ + my $model = shift @_; + my $gr = $model->VizGraphs; + getRuleNetworkGraphs($model); + my $mtypes = $model->MoleculeTypesList->MolTypes; + my @statepatternlist; + foreach my $mname(keys %$mtypes) + { + my $ctypes = $$mtypes{$mname}->Components; + foreach my $comp(@$ctypes) + { + my $cname = $comp->Name; + my @states = @{$comp->States}; + for(my $i=0; $i<@states; $i++) + { + my $str = $mname."(".$cname."~".$states[$i].")"; + push @statepatternlist, $str; + } + } + + } + if(not defined $gr->{'ContactMap'}) + { + my $psg = makeContactMap( [ flat(@{$gr->{'RuleNetworkGraphs'}}) ], \@statepatternlist ); + $gr->{'ContactMap'} = $psg; + } + return; +} + +sub applyRuleNetworkCurrent +{ + my $model = shift @_; + my $bpg = shift @_; + $model->VizGraphs->{'RuleNetworkCurrent'} = $bpg; + return; +} + +sub getRuleGroups +{ + my $model = shift @_; + my $gr = $model->VizGraphs; + my $bpg = $gr->{'RuleNetwork'}; + # this is to be used only by rule_pattern and rule_operation + my %classes = %{$bpg->{'NodeClass'}}; + my @rules = grep {$bpg->{'NodeType'}->{$_} eq 'Rule'} @{$bpg->{'NodeList'}}; + + + +} +# other get methods +sub getAtomicPatterns +{ + my @stringarr = @{shift @_}; + my @x; + foreach my $pat(@stringarr) + { + my $ap = stringToAtomicPattern($pat); + if(length($ap) > 0) + { + push @x, $ap; + } + else { return $pat; } + } + #$arr = \@x; + return \@x; +} +sub syncClasses +{ + my $model = shift @_; + my $bpg = shift @_; + my $classes_in = @_ ? shift @_ : undef; + my $doNotUseContextWhenGrouping = @_ ? shift @_ : 0; + #print map $_." ".$$classes_in{$_}."\n", keys %$classes_in; + + my $gr = $model->VizGraphs; + if(not defined $gr->{'Classes'}) + { + $gr->{'Classes'} = {}; + } + + if(not defined $bpg->{'NodeClass'}) + { + $bpg->{'NodeClass'} = {}; + } + + + # get only the atomic patterns + my @aps = grep {$bpg->{'NodeType'}->{$_} eq 'AtomicPattern'} + @{$bpg->{'NodeList'}}; + + # updating classes_in to include wildcards + if(defined $classes_in) + { + my @wcs = grep /\!\+/, @aps; + foreach my $wc(@wcs) + { + # get wildcard relations + next if (has([keys %$classes_in],$wc)); + my @matches = map { $_ =~ /.*:(.*):.*/; $1;} + grep { $_ =~ quotemeta $wc } + grep { $_ =~ /Wildcard$/ } + @{$bpg->{'EdgeList'}} ; + next if ( scalar( grep {has([keys %$classes_in],$_)==0} @matches)); + next if ( scalar( uniq( map {$classes_in->{$_}} @matches ) ) > 1 ); + $classes_in->{$wc} = $classes_in->{$matches[0]}; + #if(scalar(@matches) ==1) { $classes_in->{$wc} = $matches[0]; } + } + } + + # update bpg and model using %$classes_in + if(defined $classes_in) + { + my @aps2 = grep { has([keys %$classes_in],$_); } @aps; + map + { + $gr->{'Classes'}->{$_} = $classes_in->{$_}; + $bpg->{'NodeClass'}->{$_} = $classes_in->{$_}; + } @aps2; + + } + + # creating temp hash to hold for each AP + # either the class (if classed) or + # its name (if unclassed) + my @classed = keys %{$bpg->{'NodeClass'}}; + my @unclassed = grep has(\@classed,$_)==0, @aps; + my %temp; + @temp { @classed } = @{$bpg->{'NodeClass'}} { @classed }; + @temp { @unclassed } = @unclassed; + + # getting rules + #my @rules = map {quotemeta($_)} + # grep {$bpg->{'NodeType'}->{$_} eq 'Rule'} + # @{$bpg->{'NodeList'}}; + my @edges = grep { $_ =~ /Reactant|Product$/ } + @{$bpg->{'EdgeList'}}; + my @reac_edges = grep { $_ =~ /Reactant$/ } + @{$bpg->{'EdgeList'}}; + my @prod_edges = grep { $_ =~ /Product$/ } + @{$bpg->{'EdgeList'}}; + my @cont_edges = grep { $_ =~ /Context$/ } + @{$bpg->{'EdgeList'}}; + my %reacprodhash; + # dont wanna lose the order; + my @reacprodvals; + my @rules = grep {$bpg->{'NodeType'}->{$_} eq 'Rule'} @{$bpg->{'NodeList'}}; + foreach my $rule(@rules) + { + my @reac = uniq + sort {$a cmp $b} + map { $temp{$_} } + map { $_ =~ /.*:(.*):.*/; $1; } + grep { $_ =~ /^(.*):.*:.*/; $1 eq $rule; } + @reac_edges; + my @prod = uniq + sort {$a cmp $b} + map { $temp{$_} } + map { $_ =~ /.*:(.*):.*/; $1; } + grep { $_ =~ /^(.*):.*:.*/; $1 eq $rule; } + @prod_edges; + my @cont = uniq + sort {$a cmp $b} + map { $temp{$_} } + map { $_ =~ /.*:(.*):.*/; $1; } + grep { $_ =~ /^(.*):.*:.*/; $1 eq $rule; } + @cont_edges; + my $str; + if($doNotUseContextWhenGrouping == 0) { $str = join(" -> ", map { join(" + ", @$_); } (\@reac,\@prod,\@cont) ); } + else { $str = join(" -> ", map { join(" + ", @$_); } (\@reac,\@prod) ); } + #my $str = join(" -> ", map { join(" + ", @$_); } (\@reac,\@prod,\@cont) ); + my $hasreacprod = @reac ? 1 : @prod ? 1 : 0; + my $reacprodstr = $hasreacprod ? $str : ''; + $reacprodhash{$rule} = $reacprodstr; + push @reacprodvals,$reacprodstr; + #print $rule.":".join(" ",@reac).":".join(" ",@prod)."\n"; + } + + # get reacprodstrings that occur multiple times + # if it occurs only once, it doesnt need a group + # prune this to delete reacprods that occur only once + my @reacprods = grep + { + my $x = $_; + $x ne '' and (scalar (grep { $_ eq $x } values %reacprodhash) >1); + } uniq @reacprodvals; + return if (scalar @reacprods == 0); + $gr->{'NewName'} = -1 if (not defined $gr->{'NewName'}); + + # assigning names to rule groups + my %names; + @names{ @reacprods } = map 'RG'.++$gr->{'NewName'}, @reacprods; + + # updating model and bpg classdefs for the grouped rules + my @rules2 = grep { has(\@reacprods,$reacprodhash{$_}) } + map unquotemeta, @rules; + foreach my $rule(@rules2) + { + $gr->{'Classes'}->{$rule} = $names{$reacprodhash{$rule}}; + $bpg->{'NodeClass'}->{$rule} = $names{$reacprodhash{$rule}}; + } + return; +} + + +sub makeClasses +{ + my $bpg = shift @_; + my @aps = grep {$bpg->{'NodeType'}->{$_} eq 'AtomicPattern'} + @{$bpg->{'NodeList'}}; + # creating temp hash to hold for each AP + # either the class (if classed) or + # its name (if unclassed) + my @classed = keys %{$bpg->{'NodeClass'}}; + my @unclassed = grep has(\@classed,$_)==0, @aps; + my %temp; + @temp { @classed } = @{$bpg->{'NodeClass'}} { @classed }; + @temp { @unclassed } = @unclassed; + + # getting rules + #my @rules = map {quotemeta($_)} + # grep {$bpg->{'NodeType'}->{$_} eq 'Rule'} + # @{$bpg->{'NodeList'}}; + my @edges = grep { $_ =~ /Reactant|Product$/ } + @{$bpg->{'EdgeList'}}; + my @reac_edges = grep { $_ =~ /Reactant$/ } + @{$bpg->{'EdgeList'}}; + my @prod_edges = grep { $_ =~ /Product$/ } + @{$bpg->{'EdgeList'}}; + my %reacprodhash; + # dont wanna lose the order; + my @reacprodvals; + my @rules = grep {$bpg->{'NodeType'}->{$_} eq 'Rule'} @{$bpg->{'NodeList'}}; + foreach my $rule(@rules) + { + my @reac = uniq + sort {$a cmp $b} + map { $temp{$_} } + map { $_ =~ /.*:(.*):.*/; $1; } + grep { $_ =~ /^(.*):.*:.*/; $1 eq $rule; } + @reac_edges; + my @prod = uniq + sort {$a cmp $b} + map { $temp{$_} } + map { $_ =~ /.*:(.*):.*/; $1; } + grep { $_ =~ /^(.*):.*:.*/; $1 eq $rule; } + @prod_edges; + my $str = join(" -> ", map { join(" + ", @$_); } (\@reac,\@prod) ); + my $hasreacprod = @reac ? 1 : @prod ? 1 : 0; + my $reacprodstr = $hasreacprod ? $str : ''; + $reacprodhash{$rule} = $reacprodstr; + push @reacprodvals,$reacprodstr; + #print $rule.":".join(" ",@reac).":".join(" ",@prod)."\n"; + } + + # get reacprodstrings that occur multiple times + # if it occurs only once, it doesnt need a group + # prune this to delete reacprods that occur only once + my @reacprods = grep + { + my $x = $_; + $x ne '' and (scalar (grep { $_ eq $x } values %reacprodhash) >1); + } uniq @reacprodvals; + return if (scalar @reacprods == 0); + my $newname = -1; + # assigning names to rule groups + my %names; + @names{ @reacprods } = map 'RG'.++$newname, @reacprods; + + # updating model and bpg classdefs for the grouped rules + my @rules2 = grep { has(\@reacprods,$reacprodhash{$_}) } + map unquotemeta, @rules; + foreach my $rule(@rules2) + { + $bpg->{'NodeClass'}->{$rule} = $names{$reacprodhash{$rule}}; + } + return; +} +sub compressRuleMotifs +{ + my $bpg = shift @_; + my @nodelist = @{$bpg->{'NodeList'}}; + my @edgelist = @{$bpg->{'EdgeList'}}; + my %nodetype = %{$bpg->{'NodeType'}}; + + my %motifs = %{shift @_}; + my @motifnames = keys %motifs; + my @rules_to_remove = uniq map { @{$motifs{$_}} } @motifnames; + + + # this is an array of strings, 2-member arrays, remap from member[0] to member [1] + my @remap_pairs; + foreach my $name(@motifnames) + { + my @x = @{$motifs{$name}}; + push @remap_pairs, map {$_.":".$name;} @x; + } + my @edges_to_remove = grep { $_=~/^(.*):.*:.*/; has(\@rules_to_remove,$1); } @edgelist; + my @new_edges = remapEdges(\@edges_to_remove,\@remap_pairs,0); + + # context edges from the input and output states of the motif will be removed + # this was done looking at mtorc.bngl results. + # THIS IS AN ASSUMPTION. There could be edge cases where this would miss out + # on some relevant context + # NEEDS TESTING! esp on fceri_ji + + my @edges_to_remove2; + foreach my $name(@motifnames) + { + my @reacprods = uniq + map { $_ =~ /^.*:(.*):.*$/; $1; } + grep { $_ =~ /^(.*):.*:.*$/; $1 eq $name; } + grep { $_ =~ /^.*:.*:(Reactant|Product)$/; } + @new_edges; + push @edges_to_remove2, map { my @x = ($name,$_,'Context'); join(':',@x);} @reacprods; + } + + my @nodelist2; + my @edgelist2; + my %nodetype2; + + map { push @nodelist2, $_ if(not has(\@rules_to_remove,$_));} @nodelist; + map { my $x = $_; $nodetype2{$x} = $nodetype{$x}; } @nodelist2; + push @nodelist2,@motifnames; + map { my $x = $_; $nodetype2{$x} = 'Rule'; } @motifnames; + + map { push @edgelist2, $_ if(not has(\@edges_to_remove,$_));} @edgelist; + map { push @edgelist2, $_ if(not has(\@edges_to_remove2,$_));} @new_edges; + #push @edgelist2,@new_edges; + + my $bpg2 = duplicateNetworkGraph($bpg); + if(scalar @rules_to_remove > 0) + { + $bpg2->{'NodeList'} = \@nodelist2; + $bpg2->{'EdgeList'} = \@edgelist2; + $bpg2->{'NodeType'} = \%nodetype2; + } + uniqNetworkGraph($bpg2); + return $bpg2,\@remap_pairs; +} + +sub remapEdges +{ + my @edges_to_remap = @{shift @_}; + my @remap_pairs = @{shift @_}; + my $element_index_to_remap = shift @_; + # edges are x:y:z, $element_index_to_remap = 0 remaps x, 1 remaps y, 2 remaps z + my @remapped_edges = (); + foreach my $edge(@edges_to_remap) + { + my $elem_to_remap = getElementInEdge($edge,$element_index_to_remap); + foreach my $remap_pair(@remap_pairs) + { + my @x = split(':',$remap_pair); + if ($elem_to_remap eq $x[$element_index_to_remap]) + { + push @remapped_edges, replaceElementInEdge($edge,$element_index_to_remap,$x[1]); + } + } + } + return @remapped_edges; +} + +sub getElementInEdge { my @x = split(':',$_[0]); $x[$_[1]];} # @_ = (edgestr,0/1/2) +sub replaceElementInEdge { my @x = split(':',$_[0]); $x[$_[1]] = $_[2]; join(':',@x);} # @_ = (edgestr,0/1/2,new_elem) + +sub getBackground +{ + print "Computing background.\n"; + my $model = shift @_; + my $include = @_ ? shift @_ : []; + my $exclude = @_ ? shift @_ : []; + + #my $except = @_ ? shift @_ : []; + my $bpg = @_ ? shift @_ : undef; + my $gr = $model->VizGraphs; + + if (not defined($gr->{'Background'})) + { + getRuleStructureGraphs($model); + my @rsgs = map {@$_;} flat($gr->{'RuleStructureGraphs'}); + my @trs = uniq(map { getTransformations($_); } @rsgs); + my %added; + my %re; + my %pr; + foreach my $tr(@trs) + { + next if($tr eq ""); + my ($reac,$prod) = getReactantsProducts($tr); + # dang, Perl is awesome! + map { $re{$_}++ if(not $added{$_}++); } @$reac; + map { $pr{$_}++ if(not $added{$_}++); } @$prod; + } + my @bkg1 = grep { has($exclude,$_)==0; } keys %re; + my @bkg2 = grep { has($include,$_)==1; } keys %pr; + my @bkg3 = grep { has(\@bkg2,$_)==0;} @$include; + my @background = (@bkg1,@bkg2,@bkg3); + $gr->{'Background'} = \@background; + } + + if(defined $bpg) + { + my @aps = grep {$bpg->{'NodeType'}->{$_} eq 'AtomicPattern'} @{$bpg->{'NodeList'}}; + my @edges = grep {$_ =~ /Reactant|Product|Wildcard$/} @{$bpg->{'EdgeList'}}; + + my @aps_1 = map {$_ =~ /^.*:(.*):.*$/; $1; } + grep {$_ =~ /Reactant|Product$/} + @{$bpg->{'EdgeList'}}; + my @aps_2 = map {$_ =~ /^(.*):.*:.*$/; $1; } + grep {$_ =~ /Wildcard$/} + @{$bpg->{'EdgeList'}}; + my @aps_3 = uniq((@aps_1,@aps_2)); + my @aps_4 = grep {(has(\@aps_3,$_)==0 and has($exclude,$_)==0) or has($include,$_)==1} @aps; + #print map $_."\n", grep {has(\@aps_3,$_)==0} @aps; + + #my @aps2 = grep {$_ =~ /\(.*\)/} uniq map { $_ =~ /.*:(.*):.*/; $1; } @edges; + #my @aps3 = grep { (has(\@aps2,$_)==0 and has($exclude,$_)==0) or has($include,$_)==1 } @aps; + + my @background = @{$gr->{'Background'}}; + #push @background, @aps3; + push @background, @aps_4; + @background = uniq @background; + $gr->{'Background'} = \@background; + + } + return; +} + +sub removeReactantContext +{ + # for each rule R1, each reactant X and its group Gr(X) + # remove all context edges from Y in Gr(X) + # as long as Y neq X + # and Y is not a reactant to R1, + + my $bpg = shift @_; + my @aps = grep {$bpg->{'NodeType'}->{$_} eq 'AtomicPattern'} + @{$bpg->{'NodeList'}}; + my @rules = grep {$bpg->{'NodeType'}->{$_} eq 'Rule'} + @{$bpg->{'NodeList'}}; + my %classes = %{$bpg->{'NodeClass'}}; + my @classed = grep {has(\@aps,$_);} keys %classes; + + + my @reac_edges = grep { $_ =~ /Reactant$/ } + @{$bpg->{'EdgeList'}}; + my @cont_edges = grep { $_ =~ /Context$/ } + @{$bpg->{'EdgeList'}}; + my @edges_to_remove; + + foreach my $rule(@rules) + { + my @reacs = grep {has(\@classed,$_);} + map {$_ =~ /.*:(.*):.*/; $1;} + grep {$_ =~ /(.*):.*:.*/; $rule eq $1;} + @reac_edges; + #print $rule." ".join(" ",@reacs)." "; + #print "\n" if (scalar @reacs ==0); + next if (scalar @reacs ==0); + my @reac_classes = uniq map {$classes{$_}} @reacs; + #print join(" ",@reac_classes)." "; + my @relevant_cont_edges = + grep {$_ =~ /.*:(.*):.*/; has(\@reac_classes,$classes{$1});} + grep {$_ =~ /.*:(.*):.*/; has(\@classed,$1);} + grep {$_ =~ /.*:(.*):.*/; not has(\@reacs,$1);} + grep {$_ =~ /(.*):.*:.*/; $rule eq $1;} + @cont_edges; + #print join(" ",@relevant_cont_edges)."\n"; + push @edges_to_remove, @relevant_cont_edges; + } + + my $bpg2 = duplicateNetworkGraph($bpg); + if(scalar @edges_to_remove) + { + my @new_edges = grep {not has(\@edges_to_remove,$_);} @{$bpg2->{'EdgeList'}}; + $bpg2->{'EdgeList'} = \@new_edges; + } + return $bpg2; +} + +sub makeInhibitionEdges +{ + my $bpg = shift @_; + my @inh = uniq @{shift @_}; + my @remap_pairs = @{shift @_}; + + my @aps = grep {$bpg->{'NodeType'}->{$_} eq 'AtomicPattern'} + @{$bpg->{'NodeList'}}; + my @rules = grep {$bpg->{'NodeType'}->{$_} eq 'Rule'} + @{$bpg->{'NodeList'}}; + my @reac_edges = grep { $_ =~ /Reactant$/ } + @{$bpg->{'EdgeList'}}; + + + my %remaps; + my @remapped; + map { my $x = $_; my @y = split(':',$x); + $remaps{$y[0]} = $y[1]; + push @remapped,$y[0]; } @remap_pairs; + + my @edges_to_remove; + my @edges_to_add; + + foreach my $line(@inh) + { + my @ar = split(":",$line); + my $line_error = 0; + $line_error = 1 if(scalar (@ar) != 2); + if( scalar (@ar) == 2 ) + { + $line_error = 1 if(not has(\@rules,$ar[0]) and not has(\@remapped,$ar[0]) ); + $line_error = 1 if(not has(\@aps,$ar[1]) ); + } + if($line_error==1) + { + print "ERROR processing line ".$line." in inhibition block. \nEither bad format or rule or atomic pattern was not present in foreground. Use RuleName:AtomicPattern. Skipping...\n"; + next; + } + my $findline = has(\@remapped,$ar[0]) ? $remaps{$ar[0]}.":".$ar[1] : $line; + if( not has(\@reac_edges,$findline.":Reactant") ) + { + print "ERROR processing line ".$line." in inhibition block. \nCould not find relevant reactant edge. Skipping...\n"; + next; + } + push @edges_to_remove, $findline.":Reactant"; + push @edges_to_add, $findline.":Inhibition"; + } + + my $bpg2 = duplicateNetworkGraph($bpg); + if(scalar @edges_to_remove) + { + my @new_edges = grep {not has(\@edges_to_remove,$_);} @{$bpg2->{'EdgeList'}}; + push @new_edges, @edges_to_add; + $bpg2->{'EdgeList'} = \@new_edges; + } + return $bpg2; +} + +sub duplicate_args +{ + my %args = %{shift @_}; + my %args2; + map {$args2{$_} = $args{$_}} keys %args; + return %args2; +} + +######################### + +sub display_viz_help +{ + print qq{ +---------------------------------------------/ HELP MENU /---------- +SYNOPSIS: + + visualize({help=>1}) show this help menu + visualize({type=>"TYPE"}) make visualization of type TYPE + TYPE "regulatory" is used as default if --type is not used. + + ----------------------- + Allowed values for TYPE + ----------------------- + conventional conventional rule visualization + compact compact rule visualization (using graph operation nodes) + regulatory rule-derived regulatory graph + opts options template for regulatory graph + contactmap contact map + reaction_network reaction network + +OPTIONS: + + ------------------------ + Common Action Parameters + ------------------------ + suffix=>"STR" add suffix STR to output filename + + ----------------------------------------------------------------- + Action Parameters for TYPE "conventional", "compact","regulatory" + ----------------------------------------------------------------- + each=>0/1 show all rules in the same/separate GML files (default: 0) + + --------------------------------------- + Action Parameters for TYPE "regulatory" + --------------------------------------- + opts=>"FILE" import options file named FILE + opts=>["FILE1","FILE2",...] import multiple options files + background=>0/1 disable/enable background (default: 0) + groups=>0/1 disable/enable groups (default: 0) + collapse=>0/1 disable/enable collapsing of groups (default: 0) + ruleNames=>0/1 disable/enable display of rule names (default: 0) + doNotUseContextWhenGrouping=>0/1 use strict/permissive edge signature (default: 0) + doNotCollapseEdges=>0/1 when collapsing nodes, remove/retain duplicate edges (default: 0) + +NOTES: + (i) To obtain a template options file for a model, use TYPE "opts". + You can edit this file and import it as opts=>"FILE". + (ii) To obtain full model regulatory graph, use background=>1 and all other options set to default. + (iii) To show rule names and rule group names on the regulatory graph, use ruleNames=>1. + + } + +} + +sub display_viz_help_old +{ + my $args = @_ ? shift @_ : 0; + + if($args==0) { + print qq{ +---------------------------------------------/ HELP MENU /---------- +ACTION: visualize +SYNOPSIS: + + visualize({help=>1}) show this help menu + visualize({help=>1,type=>"TYPE"}) show help on visualization of type TYPE + visualize({type=>"TYPE"}) make visualization of type TYPE + + Allowed types: {ruleviz_pattern, ruleviz_operation, regulatory, reaction_network, contactmap, process} + +OPTIONS: + + File I/O + -------- + opts=>"FILE" use input options file FILE + opts=>["FILE1","FILE2",...] use multiple input options files + textonly=>0/1 disable/enable text-only output of visualization (default: 0) + suffix=>"STR" add suffix STR to output filename + + Viz config + ---------- + type=>"TYPE" create visualization of type TYPE (default: regulatory) + background=>0/1 disable/enable background (default: 0) + groups=>0/1 disable/enable grouping (default: 0) + each=>0/1 disable/endable separate outputs of each rule/group (default: 0) +} + } + + elsif($args->{'type'} eq 'regulatory') + { + print qq{ +---------------------------------------------/ HELP MENU /---------- +ACTION: visualize +TYPE: regulatory +PURPOSE: Generates a regulatory network of rules and atomic patterns. + +OPTIONS SET 1: + +visualize({type=>"regulatory", background=>0/1, opts=>[FILE1,FILE2,...], filter=>0/1, level=>INT, groups=>0/1}) + +background=>0/1 (default: 0) +---------------------------- +Disable/enable background. When 0, some patterns are determined to +be background and removed from network graph. The assignment can be +modified using the options file. + +opts=>["FILE1","FILE2",...] +--------------------------- +Specifies option file(s) with the following structure: + + begin background + + end background + begin filter + + end filter + begin classes + begin classname + + end classname + end classes + + is a whitespace-separated list of patterns. +'classname' refers to arbitrary names for pattern classes. +All blocks are optional. + +filter=>0/1, level=>INT +(Defaults: filter=>0, level=>1) +------------------------------- +Disable/enable generation of a subgraph starting from a defined +set of nodes and propagating along the edges 'level' levels deep. +The starting nodes are defined in the options file. + +groups=>0/1 (default: 0) +------------------------ +Disables/enables grouping. Patterns are grouped using classes +that are provided in the options file. Rules are grouped +automatically based on pattern relationships. + +OPTIONS SET 2: + +visualize({type=>"regulatory", groups=>0/1, collapse=>0/1, textonly=>0/1}) + +collapse=>0/1 +------------- +Disable/enable computation of a smaller network graph where groups of nodes +are replaced by a single node representing the group. Requires groups=>1. + +textonly=>0/1 +------------- +Disable/enable output of a text-only version of the model network graph. + +OPTIONS SET 3: + +visualize({groups=>0/1, each=>0/1}) + +each=>0/1 +--------- +Disable/enable separate output of each rule (or rule group if groups=>1). + +Option sets 2 and 3 are compatible with set 1 but incompatible with each other. + +For help on file input and output options try: visualize({help=>1}) +To start working on a model try: + +visualize({type=>"regulatory", groups=>1}) +} + } + + elsif($args->{'type'} eq 'process') + { + print qq{ +---------------------------------------------/ HELP MENU /---------- +ACTION: visualize +TYPE: process +PURPOSE: Generates a process diagram of rules and atomic patterns. + +USAGE: + +visualize({type=>"process", background=>0/1, opts=>[FILE1,FILE2,...], groups=>0/1, mergepairs=>0/1, textonly=>0/1}) + +background=>0/1 (default: 0) +---------------------------- +Disable/enable background. When 0, some patterns are determined to +be background and removed from network graph. The assignment can be +modified using the options file. + +opts=>["FILE1","FILE2",...] +--------------------------- +Specifies option file(s) with the following structure: + + begin background + begin include + + end include + + begin exclude + + end exclude + end background + + begin filter + + end filter + + begin classes + begin classname + + end classname + end classes + + is a whitespace-separated list of patterns. +'classname' refers to arbitrary names for pattern classes. +All blocks are optional. + +groups=>0/1 (default: 0) +------------------------ +Disables/enables grouping. Patterns are grouped using classes +that are provided in the options file. Rules are grouped +automatically based on pattern relationships. + +textonly=>0/1 +------------- +Disable/enable output of a text-only version of the model network graph. + +For help on file input and output options try: visualize({help=>1}) +To start working on a model try: + +visualize({type=>process, groups=>1}) +} + } + + elsif($args->{'type'} eq 'ruleviz_pattern') + { + print qq{ +---------------------------------------------/ HELP MENU /---------- +ACTION: visualize +TYPE: ruleviz_pattern +PURPOSE: Visualizes rules as bipartite graphs with embedded pattern graphs. +USAGE: + +visualize({type=>"ruleviz_pattern", each=>0/1}) + +each=>0/1 (default: 0) +--------- +Disable/enable separate output of each rule. +} + } + + elsif($args->{'type'} eq 'ruleviz_operation') + { + print qq{ +---------------------------------------------/ HELP MENU /---------- +ACTION: visualize +TYPE: ruleviz_operation +PURPOSE: Visualizes rules as pattern graphs with graph operation nodes. +USAGE: + +visualize({type=>"ruleviz_operation", each=>0/1}) + +each=>0/1 (default: 0) +--------- +Disable/enable separate output of each rule. + + } + } + elsif($args->{'type'} eq 'reaction_network') + { + print qq{ +No help yet for 'reaction_network'. Please check back later. +} + } + + elsif($args->{'type'} eq 'contactmap') + { + print qq{ +---------------------------------------------/ HELP MENU /---------- +ACTION: visualize +TYPE: ruleviz_pattern +PURPOSE: Visualizes rules as bipartite graphs with embedded pattern graphs. +USAGE: + +visualize({type=>"contactmap", each=>0/1}) + +each=>0/1 (default: 0) +--------- +Disable/enable separate output of each rule. +} + } + + else + { + print $args->{'type'} . " is not a valid visualization type.\n"; + } + + return ""; +} + +sub writeExampleOpts +{ + my $bpg = shift @_; + my %mtypes = %{shift @_}; + my @aps = grep {$bpg->{'NodeType'}->{$_} eq 'AtomicPattern'} @{$bpg->{'NodeList'}}; + my @rules = grep {$bpg->{'NodeType'}->{$_} eq 'Rule'} @{$bpg->{'NodeList'}}; + + my @reverse_rules = grep {/^_reverse_/} @rules; + my @other_rules = grep {not /^_reverse_/} @rules; + + my @freebindingsites = grep { /\(/ and not /\~/ and not /\!/ } @aps; + my @bonds = grep {/\!/} @aps; + my @internalstates = grep {/\~/} @aps; + my @mol_aps = grep {not /\(/ and not /\~/ and not /\!/ } @aps; + + # categorizing similarity of components + my @comps = @freebindingsites; + my %internalstatesignature = map {$_=>-1} @comps; + # background-foreground + my @bkg_is = (); + foreach my $comp (@comps) + { + $comp =~ /^(.*)\((.*)\)$/; + my ($m,$c) = ($1,$2); + my @istates = uniq map {@{$_->States}} grep {$_->Name eq $c} @{$mtypes{$m}->Components}; + push @bkg_is,$m."(".$c."~".$istates[0].")" if (scalar @istates > 1); + } + + # compiling foreground and background + my @t = (@reverse_rules,@freebindingsites,@bkg_is); + my @background = grep { has(\@t,$_)==1 } (@aps,@rules); + my @foreground = grep { has(\@background,$_)==0 } (@aps,@rules); + + # assigning atomic pattern groups + my %groups; + # assigning bonds to groups + my @bnds = grep {has(\@foreground,$_)} @bonds; + foreach my $bond(@bnds) { + $bond =~ /^(.*)\(.*\)[.](.*)\(.*\)$/; + my $x = join "|", sort ($1,$2); + $groups{$bond} = $x; + } + # assigning internal states to groups + my @ints = grep { has(\@foreground,$_)} @internalstates; + foreach my $int(@ints) { + $int =~ /^(.*)\(.*\~(.*)\)$/; + my $x = $1."_".$2; + $groups{$int} = $x; + } + + # building output string + # included + my @ap1 = sort grep {has(\@background,$_)} @aps; + my @rule1 = sort grep {has(\@background,$_)} @rules; + my $inclstr = "\t\t".join("\n\t\t", map {join(" ",@$_)} (natatime2(@ap1),natatime2(@rule1))); + + # excluded + my @ap2 = sort grep {not has(\@background,$_)} @aps; + my @rule2 = sort grep {not has(\@background,$_)} @rules; + my $exclstr = "\t\t".join("\n\t\t", map {join(" ",@$_)} (natatime2(@ap2),natatime2(@rule2))); + + + # groups + my @grpstrs = (); + my @ap3 = keys %groups; + my @ap4 = grep {has(\@ap3,$_)} @ap2; + my @grpnames = uniq values %groups; + + foreach my $grp(sort @grpnames) + { + my @ap5 = grep {$groups{$_} eq $grp} @ap4; + my @strlist = ("\tbegin ",$grp,"\n\t\t",join(" ",@ap5),"\n\tend ",$grp); + my $str = join("",@strlist); + push @grpstrs,$str; + } + my $grpstr = join("\n",@grpstrs); + + my @retstrs = (); + push @retstrs, "begin background","\tbegin include",$inclstr,"\tend include"; + push @retstrs, "\tbegin exclude",$exclstr,"\tend exclude","end background"; + push @retstrs, "begin classes",$grpstr,"end classes"; + my $ret = join("\n",@retstrs); + return $ret; +} + +sub natatime2 { + # n at a time + my $n = 5; + my @list = @_; + my @ret = (); + while (my @x = splice @list, 0, $n) + { push @ret,\@x;} + # Array of arrayrefs + return @ret; +} + + + +1; diff --git a/libvcell/vcell_install/bionetgen/Perl2/Visualization/analyze.pl b/libvcell/vcell_install/bionetgen/Perl2/Visualization/analyze.pl new file mode 100644 index 0000000..d0ada35 --- /dev/null +++ b/libvcell/vcell_install/bionetgen/Perl2/Visualization/analyze.pl @@ -0,0 +1,669 @@ +#!/usr/bin/perl +# pragmas +package Viz; +use strict; +use warnings; +use File::Spec; +use warnings; +use FindBin; +use Getopt::Long; +use lib File::Spec->catdir( + ( exists $ENV{'BNGPATH'} ? $ENV{'BNGPATH'} : + ( exists $ENV{'BioNetGenRoot'} ? $ENV{'BioNetGenRoot'} : + do { + my ($vol,$dir,$file) = File::Spec->splitpath( $FindBin::RealBin ); + my @dirs = File::Spec->splitdir($dir); + pop @dirs; + pop @dirs; + File::Spec->catpath($vol,File::Spec->catdir(@dirs)) + } + ) + ),'Perl2' + ); + +use BNGModel; +use Visualization::Viz; +use Visualization::VisOptParse; +use Cwd; +use Class::Struct; + +# Get list of bngls +my $dir = getcwd; +my @bngls = getModelsList($dir); + +#@bngls = (); + +my $outfile1 = "data_rules.csv"; +open(my $fh1, ">", $outfile1) or die "Cannot open"; +print $fh1 "Model,RuleName,RuleSize,RuleStructSize,RuleRegSize\n"; +foreach my $bngl(@bngls) +{ + $bngl =~ /^(.*).bngl$/; + my $modelname = $1; + my $model = getModel($bngl); + initializeGraphsObject($model); + my $gr = $model->VizGraphs; + + # 1 + getRuleNames($model); + my @rules = flat @{$gr->{'RuleNames'}}; + my @reverses = grep { $_ =~ /^_reverse.*$/} @rules; + + # 2 + getRulePatternGraphs($model); + my @rpgs = flat @{$gr->{'RulePatternGraphs'}}; + my %lstathash; my %rstathash; # hash in which values are stathashes + # left and right merged pattern structure graphs + # example of how to access data + # print $rstathash{'R19'}->{'UnboundComponents'}; + foreach my $rpg(@rpgs) + { + my ($lstats,$rstats) = getPSGstats($rpg); + my $name = $lstats->{'RuleName'}; + $lstathash{$name} = $lstats; + $rstathash{$name} = $rstats; + } + + # example of how to access data + # print $rstathash{'R19'}->{'UnboundComponents'}; + getRuleStructureGraphs($model); + my @rsgs = flat @{$gr->{'RuleStructureGraphs'}}; + my %rsg_stathash; + foreach my $rsg(@rsgs) + { + my $stats = getRSGstats($rsg); + my $name = $stats->{'RuleName'}; + $rsg_stathash{$name} = $stats; + } + + getRuleNetworkGraphs($model); + my @rrgs = flat @{$gr->{'RuleNetworkGraphs'}}; + my %rrgsize; + foreach my $rrg(@rrgs) + { + + my %nodetype = %{$rrg->{'NodeType'}}; + my @nodelist = @{$rrg->{'NodeList'}}; + + my $name = join "", grep {$nodetype{$_} eq 'Rule'} @nodelist; + my $size = scalar @nodelist; + $rrgsize{$name} = $size; + } + + # rule size (as defined in syntax) + my %rulesize; + foreach my $rule(@rules) + { + my %lhash = %{$lstathash{$rule}}; + my %rhash = %{$rstathash{$rule}}; + my @arr = qw(Molecules Components UnboundComponents Bonds WildcardBonds InternalStates); + my $size = 0; + map { $size = $size + $lhash{$_} + $rhash{$_}} @arr; + $rulesize{$rule} = $size; + #print $modelname." ".$rule." ".$rulesize{$rule}."\n"; + } + + # rsg size + my %rsgsize; + foreach my $rule(@rules) + { + my %stat = %{$rsg_stathash{$rule}}; + my @arr = qw(Molecules Components UnboundComponents Bonds WildcardBonds InternalStates); + my $size = 0; + map { $size = $size + $stat{$_} } @arr; + $rsgsize{$rule} = $size; + } + + #my $outfile = "data_rules.csv"; + #open(my $fh, ">", $outfile) or die "Cannot open"; + #print $fh "Model,RuleName,RuleSize,RuleStructSize,RuleRegSize\n"; + + foreach my $rule(@rules) + { + print $fh1 join(",",$modelname,$rule,$rulesize{$rule},$rsgsize{$rule},$rrgsize{$rule})."\n"; + } + + #undef $gr,$model; +} +close $fh1; + +# model-wide statistics +my $outfile2 = "data_models_nodes.csv"; +my $outfile3 = "data_models_edges.csv"; +open(my $fh2, ">", $outfile2) or die "Cannot open"; +open(my $fh3, ">", $outfile3) or die "Cannot open"; +print $fh2 "Model,RInf,CMap,ConvRule,CompactRule,SimmuneNet,FullReg,RegNoBkg,RegGrps,RegGrpsNoCtxt\n"; +print $fh3 "Model,RInf,CMap,ConvRule,CompactRule,SimmuneNet,FullReg,RegNoBkg,RegGrps,RegGrpsNoCtxt\n"; +#@bngls = ('Faeder2003.bngl'); +#@bngls = ('An2009.bngl'); +#@bngls = ('Faeder2003.bngl','An2009.bngl','Ligon2014.bngl'); +my %rinfnodes; my %rinfedges; +my %cmapnodes; my %cmapedges; +my %convrulenodes; my %convruleedges; +my %compactrulenodes; my %compactruleedges; +my %fullregnodes; my %fullregedges; +my %regnobkgnodes; my %regnobkgedges; +my %reggrpsnodes; my %reggrpsedges; +my %reggrpsnoctxtnodes; my %reggrpsnoctxtedges; +my %simmunenodes; my %simmuneedges; +#my %rxnnetnodes; my %rxnnetedges; +foreach my $bngl(@bngls) +{ + $bngl =~ /^(.*).bngl$/; + my $modelname = $1; + my $model = getModel($bngl); + initializeGraphsObject($model); + my $gr = $model->VizGraphs; + getRuleNames($model); + getRuleNetwork($model); + + # RINF + my $bpg = $gr->{'RuleNetwork'}; + my $rinf = makeRINF($bpg); + $rinfnodes{$modelname} = scalar @{$rinf->{'Nodes'}}; + $rinfedges{$modelname} = scalar @{$rinf->{'Edges'}}; + + # CMap + my $mtypes = $model->MoleculeTypesList->MolTypes; + my @cmapstats = getCMAPStats($mtypes,$bpg); + $cmapnodes{$modelname} = $cmapstats[0]; + $cmapedges{$modelname} = $cmapstats[1]; + + # ConvRule + getRulePatternGraphs($model); + my ($convnodes,$convedges) = getConvRuleStats($gr->{'RulePatternGraphs'},$gr->{'RuleNames'}); + $convrulenodes{$modelname} = $convnodes; + $convruleedges{$modelname} = $convedges; + + # CompactRule + getRuleStructureGraphs($model); + my ($comprulenodes,$compruleedges) = getCompactRulesStats($gr->{'RuleStructureGraphs'}); + $compactrulenodes{$modelname} = $comprulenodes; + $compactruleedges{$modelname} = $compruleedges; + + # FullReg + getRuleNetwork($model); + $bpg = $gr->{'RuleNetwork'}; + $fullregnodes{$modelname} = scalar @{$bpg->{'NodeList'}}; + $fullregedges{$modelname} = scalar @{$bpg->{'EdgeList'}}; + + # OptsFileOut + my %q = initializeExecParams(); + $q{'type'} = 'opts'; + execute_params($model,\%q); + + # RegNoBkg + my %p = initializeExecParams(); + my $optsname = $modelname."_opts.txt"; + $p{'background'} = 0;$p{'opts'} = [$optsname]; $p{'groups'} = 0; $p{'collapse'}=0;$p{'type'}='regulatory'; + my @x = parseOpts($optsname); + my %bkg = %{$x[1]}; my %cls = %{$x[2]}; + $bpg = filterNetworkGraph($bpg,$bkg{'include'}); + $regnobkgnodes{$modelname} = scalar @{$bpg->{'NodeList'}}; + $regnobkgedges{$modelname} = scalar @{$bpg->{'EdgeList'}}; + + # RegGrps + my $bpg2 = $bpg; + my $donotusecontext = 0; + my %classes_in; + foreach my $grpname(keys %cls) + { + map {$classes_in{$_} = $grpname;} @{$cls{$grpname}}; + } + syncClasses($model,$bpg2,\%classes_in,$donotusecontext); + $bpg2 = collapseNetworkGraph($bpg2); + $reggrpsnodes{$modelname} = scalar @{$bpg2->{'NodeList'}}; + $reggrpsedges{$modelname} = scalar @{$bpg2->{'EdgeList'}}; + + # RegGrpsNoCtxt + $bpg2 = $bpg; $donotusecontext = 1; + $model->VizGraphs->{'Classes'} = {}; + syncClasses($model,$bpg2,\%classes_in,$donotusecontext); + $bpg2 = collapseNetworkGraph($bpg2); + $reggrpsnoctxtnodes{$modelname} = scalar @{$bpg2->{'NodeList'}}; + $reggrpsnoctxtedges{$modelname} = scalar @{$bpg2->{'EdgeList'}}; + + # SimmuneNet + my ($sim_n,$sim_e) = getSimmuneNetworkStats($model->RxnRules,$model->MoleculeTypesList->MolTypes); + $simmunenodes{$modelname} = $sim_n; + $simmuneedges{$modelname} = $sim_e; + + # reaction network - old + #if( -e $modelname.".net") { + #my ($rxn_n,$rxn_e) = getRxnNetStats($modelname); + #$rxnnetnodes{$modelname} = $rxn_n; + #$rxnnetedges{$modelname} = $rxn_e; + #} + #else + #{ + #$rxnnetnodes{$modelname} = "NaN"; + #$rxnnetedges{$modelname} = "NaN"; + #} + my @str1 = ($modelname,$rinfnodes{$modelname},$cmapnodes{$modelname}, + $convrulenodes{$modelname},$compactrulenodes{$modelname},$simmunenodes{$modelname}, + $fullregnodes{$modelname},$regnobkgnodes{$modelname}, + $reggrpsnodes{$modelname},$reggrpsnoctxtnodes{$modelname}); + my @str2 = ($modelname,$rinfedges{$modelname},$cmapedges{$modelname}, + $convruleedges{$modelname},$compactruleedges{$modelname},$simmuneedges{$modelname}, + $fullregedges{$modelname},$regnobkgedges{$modelname}, + $reggrpsedges{$modelname},$reggrpsnoctxtedges{$modelname}); + + print $fh2 join(",",@str1)."\n"; + print $fh3 join(",",@str2)."\n"; +} +close $fh2; +close $fh3; +#@bngls = ('Faeder2003.bngl'); + +# rule vs rxnnet statistics +my $outfile4 = "data_models_rxns.csv"; +open(my $fh4, ">", $outfile4) or die "Cannot open"; +print $fh4 "Model,Patterns,Rules,Species,Reactions\n"; +foreach my $bngl(@bngls) +{ + $bngl =~ /^(.*).bngl$/; + my $modelname = $1; + next unless (-e $modelname.".net"); + my $model = getModel($bngl); + initializeGraphsObject($model); + getRuleNames($model); + getRulePatternGraphs($model); + my ($patt,$rules) = getConvRuleStats2($model->VizGraphs->{'RulePatternGraphs'}); + my ($sp,$rxn) = getRxnNetStats($modelname); + my @x = ($modelname,$patt,$rules,$sp,$rxn); + print $fh4 join(",",@x)."\n"; +} +close $fh4; + +sub getConvRuleStats2 +{ + # this only counts patterns and rules + my @rrs = @{shift @_}; + my $patt=0; my $rules=0; + foreach my $rr(@rrs) + { + my $rule = $rr->[0]; + my ($lstats,$rstats) = getPSGstats($rule); + my $hasrev = scalar(@$rr) - 1; + $patt += $lstats->{'Patterns'} + $rstats->{'Patterns'}; + $rules += 1; + if($hasrev) {$rules+=1;} + } + return ($patt,$rules); +} + +sub getRxnNetStats +{ + my $modelname = shift @_; my $outfile = $modelname.".net"; + open(my $fh, "<", $outfile) or die "Cannot open"; + my @lines = <$fh>; + close $fh; + + # counters for species and reactions + my $sp = 0; my $rxn = 0; + # toggles + my $is_rxn = 0; my $is_sp = 0; + foreach my $line(@lines) + { + if($line =~ /begin reactions/) {$is_rxn = 1; $is_sp = 0; next;} + if($line =~ /begin species/) {$is_rxn = 0; $is_sp = 1; next;} + if($line =~ /end reactions/ or $line =~ /end species/ ) {$is_rxn = 0; $is_sp = 0; next;} + if($is_rxn==1) {$rxn++;} + if($is_sp==1) {$sp++;} + } + return ($sp,$rxn); +} +sub getCompactRulesStats +{ + my @rsgs = flat(@{shift @_}); + my $n = 0; my $e = 0; + foreach my $rsg(@rsgs) + { + $n++; $e++; + my %stats = %{getRSGstats($rsg)}; + $n = $n + $stats{'Molecules'} + $stats{'Components'} + $stats{'InternalStates'}; + $e = $e + $stats{'Components'} + $stats{'InternalStates'}; + $n = $n + $stats{'WildcardBonds'}; + $e = $e + $stats{'WildcardBonds'}; + $e = $e + $stats{'Bonds'} - $stats{'BondOperations'}; + $n = $n + $stats{'BondOperations'} + $stats{'StateOperations'} + $stats{'MoleculeOperations'}; + $e = $e + 2*$stats{'BondOperations'} + 2*$stats{'StateOperations'} + $stats{'MoleculeOperations'}; + } + return ($n,$e); +} +sub getConvRuleStats +{ + my @rrs = @{shift @_}; + my @rnames = flat(@{shift @_}); + my $n = 0; my $e = 0; + $n = $n + scalar(@rnames); + foreach my $rr(@rrs) + { + my $rule = $rr->[0]; + my $hasrev = scalar(@$rr) - 1; + my $rname = $rule->{'Name'}; + my ($lstats,$rstats) = getPSGstats($rule); + $n = $n + $lstats->{'Patterns'} + $rstats->{'Patterns'}; + $e = $e + $lstats->{'Patterns'} + $rstats->{'Patterns'}; + if($hasrev) {$e = $e + $lstats->{'Patterns'} + $rstats->{'Patterns'};} + $n = $n + $lstats->{'Molecules'} + $lstats->{'Components'} + $lstats->{'InternalStates'}; + $n = $n + $rstats->{'Molecules'} + $rstats->{'Components'} + $rstats->{'InternalStates'}; + $e = $e + $lstats->{'Components'} + $lstats->{'InternalStates'}; + $e = $e + $rstats->{'Components'} + $rstats->{'InternalStates'}; + $n = $n + $lstats->{'WildcardBonds'} + $rstats->{'WildcardBonds'}; + $e = $e + $lstats->{'WildcardBonds'} + $rstats->{'WildcardBonds'} + $lstats->{'Bonds'} + $rstats->{'Bonds'};; + } + return ($n,$e); +} +sub getCMAPStats +{ + my %mtypes = %{shift @_}; + my $bpg = shift @_; + my $n=0; my $e = 0; my %stoich; + foreach my $mname(keys %mtypes) + { + $n++; + my $ctypes = $mtypes{$mname}->Components; + foreach my $comp(@$ctypes) + { + $n++;$e++; + my $cname = $comp->Name; $stoich{$mname.".".$cname}++; + my @states = @{$comp->States}; + for(my $i=0; $i<@states; $i++) { $n++;$e++;} + } + } + my @bonds = grep { /\!/} @{$bpg->{'NodeList'}}; + foreach my $bond(@bonds) + { + $bond =~ /^(.*)\((.*)\!1\)[.](.*)\((.*)\!1\)$/; + my $c1 = $1.".".$2; + my $c2 = $3.".".$4; + my $count = $stoich{$c1}*$stoich{$c2}; + $e = $e + $count; + } + return ($n,$e); +} +sub new_PSG_StatsHash +{ + return ( + 'RuleName' => $_[0], + 'Side' => $_[1], + 'Patterns' => $_[2], + 'Molecules' => $_[3], + 'Components' => $_[4], + 'BoundComponents' => $_[5], + 'UnboundComponents' => $_[6], + 'Bonds' => $_[7], + 'WildcardBonds' => $_[8], + 'InternalStates' => $_[9], + ); +} +sub getSimmuneNetworkStats +{ + my @rules = flat(@{shift @_}); + my %mtypes = %{shift @_}; + my %reacprods; + my @patts; + my $n= 0; my $e = 0; + foreach my $rule(@rules) + { + # strip away components and bonds, leaving only molecules + my @reac = sort map {my $x = $_; $x =~ s/\(.*?\)//g; join ".", sort split /[.]/,$x;} + map {$_->toString()} + @{$rule->Reactants}; + my @prod = sort map {my $x = $_; $x =~ s/\(.*?\)//g; join ".", sort split /[.]/,$x;} + map {$_->toString()} + @{$rule->Products}; + push @patts, (@reac,@prod); + # each rule is a node + $n++; + # each reactant and product needs an edge + $e = $e + scalar(@reac) + scalar(@prod); + } + + @patts = uniq @patts; + my %bindingsitenum; my %internalstatenum; + foreach my $mname(keys %mtypes) + { + $bindingsitenum{$mname} = scalar @{$mtypes{$mname}->Components}; + $internalstatenum{$mname} = scalar map {@{$_->States}} @{$mtypes{$mname}->Components}; + } + foreach my $patt(@patts) + { + my @mols = split /[.]/,$patt; + # node for each molecule + map {$n += 1} @mols; + # node for each binding site and internal state + # edge for each binding site and internal state (hierarchical relation to molecule) + map {$n += $bindingsitenum{$_}+$internalstatenum{$_}} @mols; + map {$e += $bindingsitenum{$_}+$internalstatenum{$_}} @mols; + # edge for each bond, which is 1 less than number of molecules + map {$e += 1} @mols; $e = $e-1; + } + return ($n,$e); +} + +sub getRxnNetStats_old +{ + my $modelname = shift @_; my $outfile = $modelname.".net"; + open(my $fh, "<", $outfile) or die "Cannot open"; + my @lines = <$fh>; + close $fh; + + # counters for species, reactions and edges + my $n = 0; my $e = 0; + # toggles + my $is_rxn = 0; my $is_sp = 0; + foreach my $line (@lines) + { + if($line =~ /begin reactions/) {$is_rxn = 1; $is_sp = 0; next;} + if($line =~ /begin species/) {$is_rxn = 0; $is_sp = 1; next;} + if($line =~ /end reactions/ or $line =~ /end species/ ) {$is_rxn = 0; $is_sp = 0; next;} + if($is_rxn==1 or $is_sp==1) { $n++;} + if($is_rxn==1) + { + $line =~ s/#.*//g; + my @commas = $line =~ /[,]/; + my @zeros = $line =~ /\s[0]\s/; + $e = $e + 2 + scalar(@commas) - scalar(@zeros); + } + } + return ($n,$e); +} + + + + +sub new_RSG_StatsHash +{ + return ( + 'RuleName' => $_[0], + 'Molecules' => $_[1], + 'Components' => $_[2], + 'BoundComponents' => $_[3], + 'UnboundComponents' => $_[4], + 'Bonds' => $_[5], + 'WildcardBonds' => $_[6], + 'InternalStates' => $_[7], + 'BondOperations'=> $_[8], + 'StateOperations'=>$_[9], + 'MoleculeOperations'=>$_[10], + ); +} + +sub initializeGraphsObject +{ + my $model = shift @_; + my $gr = Graphs->new(); + $model->VizGraphs($gr); + $gr->{'NewName'} = -1; + return; +} + + +sub getPSGstats +{ + my $rpsg = shift @_; + my @nodelist = @{$rpsg->{'NodeList'}}; + my @ids = map { $_->{'ID'}; } @nodelist; + # node ids are like this + # RuleNum.[Re=0/Pr=1].PattNum.PattNum.MolNum.CompNum.[IntState=0,BondState=1] + # No idea why PattNum is repeated. Clean this up later. + my %lstat = new_PSG_StatsHash(); $lstat{'Side'} = 'Reactant'; + my %rstat = new_PSG_StatsHash(); $rstat{'Side'} = 'Product'; + + # partition left nodes versus right nodes versus rule node + my @rule_arr = grep { /^\d+$/ } @ids; # should be array of size 1 + + my @left = grep { /^\d+[.]0/} @ids; + my @right = grep { /^\d+[.]1/} @ids; + + my $rule_id = $rule_arr[0]; + my $rulename = join "", map {$_->{'Name'}} grep {$_->{'ID'} eq $rule_id; } @nodelist; + my $leftpatts = scalar grep { /^\d+[.]0[.]\d+$/} @left; + my $rightpatts = scalar grep { /^\d+[.]1[.]\d+$/} @right; + my $leftmols = scalar grep { /^\d+[.]\d+[.]\d+[.]\d+[.]\d+$/} @left; + my $rightmols = scalar grep { /^\d+[.]\d+[.]\d+[.]\d+[.]\d+$/} @right; + my $leftcomps = scalar grep { /^\d+[.]\d+[.]\d+[.]\d+[.]\d+[.]\d+$/} @left; + my $rightcomps = scalar grep { /^\d+[.]\d+[.]\d+[.]\d+[.]\d+[.]\d+$/} @right; + my $leftints = scalar grep { /^\d+[.]\d+[.]\d+[.]\d+[.]\d+[.]\d+[.]0$/} @left; + my $rightints = scalar grep { /^\d+[.]\d+[.]\d+[.]\d+[.]\d+[.]\d+[.]0$/} @right; + + my @lbonds = grep { /^\d+[.]\d+[.]\d+[.]\d+[.]\d+[.]\d+[.]1$/} @left; + my @rbonds = grep { /^\d+[.]\d+[.]\d+[.]\d+[.]\d+[.]\d+[.]1$/} @right; + my @lbondnodes = grep { has(\@lbonds,$_->{'ID'})==1 } @nodelist; + my @rbondnodes = grep { has(\@rbonds,$_->{'ID'})==1 } @nodelist; + my $leftwcs = scalar grep { scalar(@{$_->{'Parents'}}) == 1 } @lbondnodes; + my $rightwcs = scalar grep { scalar(@{$_->{'Parents'}}) == 1 } @rbondnodes; + my $leftbonds = scalar grep { scalar(@{$_->{'Parents'}}) == 2 } @lbondnodes; + my $rightbonds = scalar grep { scalar(@{$_->{'Parents'}}) == 2 } @rbondnodes; + my @lcomps = grep { /^\d+[.]\d+[.]\d+[.]\d+[.]\d+[.]\d+$/} @left; + my @rcomps = grep { /^\d+[.]\d+[.]\d+[.]\d+[.]\d+[.]\d+$/} @right; + my $lboundcomps = scalar uniq map { @{$_->{'Parents'}} } @lbondnodes; + my $rboundcomps = scalar uniq map { @{$_->{'Parents'}} } @rbondnodes; + my $l_unboundcomps = $leftcomps - $lboundcomps; + my $r_unboundcomps = $leftcomps - $rboundcomps; + + my @arr = ($rulename,scalar(@rule_arr),scalar(@left),scalar(@right),$leftpatts,$rightpatts,$leftmols,$rightmols,$leftcomps,$rightcomps,$leftints,$rightints,$leftbonds,$rightbonds,$leftwcs,$rightwcs,$leftbonds,$rightbonds,$lboundcomps,$rboundcomps,$l_unboundcomps,$r_unboundcomps); + + my %lstats = new_PSG_StatsHash($rulename,'Reactant',$leftpatts,$leftmols,$leftcomps,$lboundcomps,$l_unboundcomps,$leftbonds,$leftwcs,$leftints); + my %rstats = new_PSG_StatsHash($rulename,'Product',$rightpatts,$rightmols,$rightcomps,$rboundcomps,$r_unboundcomps,$rightbonds,$rightwcs,$rightints); + + return (\%lstats,\%rstats); +} + +sub getRSGstats +{ + my $rsg = shift @_; + #print printStructureGraph($rsg)."\n\n"; + + my @nodelist = @{$rsg->{'NodeList'}}; + my @ids = map { $_->{'ID'}; } @nodelist; + # node ids are like this + # RuleNum.PattNum.PattNum.MolNum.CompNum.[IntState=0,BondState=1] + # RuleNum.GraphOp + # No idea why PattNum is repeated. Clean this up later. + # PattNum is meaningless in RSG, but it remains over from merging of PSGs + + my @rule_arr = grep { /^\d+$/ } @ids; # should be array of size 1 + + my $rule_id = $rule_arr[0]; + my $rulename = join "", map {$_->{'Name'}} grep {$_->{'ID'} eq $rule_id; } @nodelist; + my $mols = scalar grep { /^\d+[.]\d+[.]\d+[.]\d+$/} @ids; + my $comps = scalar grep { /^\d+[.]\d+[.]\d+[.]\d+[.]\d+$/} @ids; + my $ints = scalar grep { /^\d+[.]\d+[.]\d+[.]\d+[.]\d+[.]0$/} @ids; + + my @bond_ids = grep { /^\d+[.]\d+[.]\d+[.]\d+[.]\d+[.]1$/} @ids; + + my @bondnodes = grep { has(\@bond_ids,$_->{'ID'})==1 } @nodelist; + my $wcs = scalar grep { scalar(@{$_->{'Parents'}}) == 1 } @bondnodes; + my $bonds_num = scalar grep { scalar(@{$_->{'Parents'}}) == 2 } @bondnodes; + my $boundcomps = scalar uniq map { @{$_->{'Parents'}} } @bondnodes; + my $unboundcomps = $comps - $boundcomps; + + + my @graphops = map {$_->{'Name'}} grep {$_->{'Type'} eq "GraphOp"} @nodelist; + my $bond_ops = scalar grep { $_ =~ /Bond/} @graphops; + my $mol_ops = scalar grep { $_ =~ /Mol/} @graphops; + my $state_ops = scalar grep { $_ =~ /State/} @graphops; + + my @arr = ($rulename,$mols,$comps,$boundcomps,$unboundcomps,$bonds_num,$wcs,$ints,$bond_ops,$state_ops,$mol_ops); + my %stat = new_RSG_StatsHash(@arr); + return \%stat; + +} + + +sub getModelsList +{ + opendir (DIR, shift @_) or die $!; + my @bngls; + while(my $file = readdir(DIR)) + { if ($file=~ /.bngl$/) {push @bngls, $file;} } + closedir DIR; + return @bngls; +} + +# Models +# Model-Name +# Rules - number of rules +# CRV-Nodes - conventional rule visualization +# CRV-Edges +# CMV-Nodes - compact rule visualization +# CMV-Edges +# SNV-Nodes - Simmune Network Viewer +# SNV-Edges +# MRG-Nodes - model regulatory graph +# MRG-Edges +# MRGC-Nodes - model regulatory graph with pruning, grouping and collapsing +# MRGC-Edges +# RINF-Nodes - rule influence diagram +# RINF-Edges +# RXN-Nodes - reaction network +# RXN-Edges + + + + + +#filecheck($args{'bngl'},'BNGL'); +#map { filecheck($_,'Opts') } @{$args{'opts'}} if defined $args{'opts'}; +#my $model = getModel($args{'bngl'}); + + +#my $exec_params = getExecParams(\%args); +#execute_params($model,$exec_params); + +sub filecheck +{ + my $file = shift @_; + my $type = shift @_; + if(not defined $file) { print $type." file not defined.\n"; exit;} + if(not -e $file) { print $type." file ".$file." not found.\n"; exit;} + print "Found ".$type." file ".$file.".\n"; + return; +} + +sub getModel +{ + my $filename = shift @_; + print "Importing model from ".$filename."\n"; + my %args = (); + $args{'file'} = $filename; + $args{'skip_actions'} = 1; + $args{'action_skip_warn'} = 1; + + #print $filename; + my $model = BNGModel->new(); + $model->initialize(); + $BNGModel::GLOBAL_MODEL = $model; + + #print "Opening file: ".$filename."\n"; + my $err = $model->readModel(\%args) ; + + if ($err) { print "ERROR:".$err."\n";} + + return $model; +} + +1; diff --git a/libvcell/vcell_install/bionetgen/Perl2/Visualization/readGML.pl b/libvcell/vcell_install/bionetgen/Perl2/Visualization/readGML.pl new file mode 100644 index 0000000..3af1987 --- /dev/null +++ b/libvcell/vcell_install/bionetgen/Perl2/Visualization/readGML.pl @@ -0,0 +1,192 @@ +#!/usr/bin/perl +use warnings; +use Getopt::Long; +use Class::Struct; + +# USAGE +# $parsed = readGML::parseGML($filename); +# @$parsed; +# print recursivelyPrintList($parsed); + +#my @list = ("node","bla","node","[", "id", "bla2", "id2", "bla3", "]", "edge","bla3"); +struct Node => +{ + 'id'=>'$', + 'gid'=>'$', + 'label'=>'$', + 'isGroup'=>'$' +}; + +struct Edge => +{ + 'source'=>'$', + 'target'=>'$' +}; + + +my $parsed = parseGML($ARGV[0]); +#print recursivelyPrintList($parsed); +#my $node = Node->new('id'=>1,'gid'=>2,'label'=>3); + +#print $node->label; +my @nodes; my @edges; +getNodesEdges(\@nodes,\@edges,$parsed); +buildPattern(\@nodes,\@edges); + + +sub buildPattern +{ + my @nodes = @{shift @_}; + my @edges = @{shift @_}; + # cleaning labels + map {$_->{'label'} =~ s/\"//g} @nodes; + # ids + my @ids = map {$_->{'id'}} @nodes; + # labels + my @labels = map {$_->{'label'}} @nodes; + # nodes that are groups + my @groups = grep {defined $_->{'isGroup'} and $_->{'isGroup'} eq '1'} @nodes; + # nodes that are nested + my @grouped = grep {defined $_->{'gid'} and has(\@ids,$_->{'gid'})} @nodes; + + + + +} + + +sub getNodesEdges +{ + my $nodes = shift @_; + my $edges = shift @_; + my @arr = @{shift @_}; + foreach my $i(0..@arr-1) + { + my $element = $arr[$i]; + if(ref($element) eq "ARRAY") { getNodesEdges($nodes,$edges,$element);} + elsif($element eq "node") { push @$nodes, getNode($arr[1]);} + elsif($element eq "edge") { push @$edges, getEdge($arr[1]);} + } +} + +sub getNode +{ + my @arr = @{shift @_}; + my $node = newNode(); + foreach my $i(0..@arr-1) + { + my ($x,$y) = @{$arr[$i]}; + if($x eq 'id') {$node->{'id'} = $y; } + elsif($x eq 'gid') {$node->{'gid'} = $y; } + elsif($x eq 'label') {$node->{'label'} = $y;} + elsif($x eq 'isGroup') {$node->{'isGroup'} = $y;} + } + return $node; +} + +sub getEdge +{ + my @arr = @{shift @_}; + my $edge = newEdge(); + foreach my $i(0..@arr-1) + { + my ($x,$y) = @{$arr[$i]}; + if($x eq 'source') {$edge->{'source'} = $y;} + elsif($x eq 'target') {$edge->{'target'} = $y;} + } + return $edge; +} + +sub newNode +{ + my $node = Node->new(); + $node->{'id'} = ''; + $node->{'gid'} = ''; + $node->{'label'} = ''; + $node->{'isGroup'} = ''; + return $node; +} +sub newEdge +{ + my $edge = Edge->new(); + $edge->{'source'} = ''; + $edge->{'target'} = ''; + return $edge; +} + +sub parseGML +{ + my $filename = shift @_; + open(my $fh, "<", $filename) + or die "cannot open < ${filename}: $!"; + my @lines = <$fh>; + close $fh; + my @list = getTokens(\@lines); + my @parsed = parseList(\@list); + #my $str = recursivelyPrintList(\@parsed); + #print $str;; + return \@parsed; + # returns a reference to a list of pairs with recursive nesting. +} + +sub getTokens +{ + my @lines = @{shift @_}; + my $line = join("",@lines); + $line =~ s/\n/ /g; + $line =~ s/\s+/ /g; + return split(/\s/,$line); +} + +sub parseList +{ + my @tokenlist = @{shift @_}; + my @outlist; + while(@tokenlist) + { + my $key = shift @tokenlist; + #print "key = ".$key."\n"; + my $token = shift @tokenlist; + my $value = $token; + #print "token = ".$token."\n"; + if($token eq "[") + { + my $i = 1; + my @newtokenlist; + while($i>0) + { + my $tok = shift @tokenlist; + $i++ if ($tok eq "["); + $i-- if ($tok eq "]"); + if($i==0) + { + #print "New token list = ".join(",",@newtokenlist)."\n"; + my $out = parseList(\@newtokenlist); + $value = $out; + } + else + { + push @newtokenlist,$tok; + } + } + } + #print "Value = ".$value."\n"; + my @pair = ($key,$value); + push @outlist, \@pair; + } + return \@outlist; +} + +sub recursivelyPrintList +{ + my $var = shift @_; + if (ref($var) ne "ARRAY") {return $var;} + if (ref($var) eq "ARRAY") { + #my @arr = map {recursivelyPrintList($_)} @$var; + return "(".join(",",map {recursivelyPrintList($_)} @$var).")"; + } + return; +} + +sub uniq { my %seen = (); grep { not $seen{$_}++ } @_; } +sub has { scalar grep ( $_ eq $_[1], @{$_[0]}); } diff --git a/libvcell/vcell_install/bionetgen/Perl2/Visualization/visualize.pl b/libvcell/vcell_install/bionetgen/Perl2/Visualization/visualize.pl new file mode 100755 index 0000000..2fcae39 --- /dev/null +++ b/libvcell/vcell_install/bionetgen/Perl2/Visualization/visualize.pl @@ -0,0 +1,270 @@ +#!/usr/bin/perl +# pragmas +package Viz; +use File::Spec; +use warnings; +use FindBin; +use Getopt::Long; +use lib File::Spec->catdir( + ( exists $ENV{'BNGPATH'} ? $ENV{'BNGPATH'} : + ( exists $ENV{'BioNetGenRoot'} ? $ENV{'BioNetGenRoot'} : + do { + my ($vol,$dir,$file) = File::Spec->splitpath( $FindBin::RealBin ); + my @dirs = File::Spec->splitdir($dir); + pop @dirs; + pop @dirs; + File::Spec->catpath($vol,File::Spec->catdir(@dirs)) + } + ) + ),'Perl2' + ); + +use BNGModel; +use Visualization::Viz; +use Visualization::VisOptParse; + +if (scalar (@ARGV) == 0) { display_help(); exit; } + +my %args = ('help'=>0,'background'=>0,'collapse'=>0,'each'=>0,'groups'=>0,'textonly'=>0,'suffix'=>'','filter'=>0,'level'=>1,'mergepairs'=>0,'embed'=>0) ; + +GetOptions( \%args, + 'help!', + 'bngl=s', + 'db=s', + 'type=s', + 'outType=s' + 'opts=s@', + 'background!', + 'collapse!', + 'each!', + 'groups!', + 'textonly!', + 'suffix=s', + 'filter!', + 'level=i', + 'mergepairs!', + 'embed!', + 'ruleNames!', + 'doNotUseContextWhenGrouping!', + 'removeReactantContext!', + 'makeInhibitionEdges!', + 'removeProcessNodes!', + 'compressRuleMotifs!', + 'doNotCollapseEdges!', + ) or die "Error in command line arguments."; + +#if(defined $args{'db'}) +#{ +# my $name = $args{'db'}; +# $name =~ /(.*)\.db/; +# my $prefix = $1; +# +# filecheck($name,'DB'); +# my $dbh = newDBFile($name); +# my $background = $args{'background'}; +# my $groups = $args{'groups'}; +# my $collapse = $args{'collapse'}; +# my $bpg = getBPG($dbh,$background,$groups,$collapse); +# my $str = toGML_rule_network($bpg); +# my $suffix = $args{'suffix'}; +# my $type = 'regulatory'; +# my %params = ('str'=>$str,'suffix'=>$suffix,'type'=>$type,'prefix'=>$prefix); +# writeGML2(\%params); +# exit; +#} + +if($args{'help'}) +{ + if(defined($args{'type'}) ) { display_help(\%args); } + else { display_help(); } + exit; +} + +if(not defined $args{'type'}) {$args{'type'} = 'regulatory'; } + +filecheck($args{'bngl'},'BNGL'); +map { filecheck($_,'Opts') } @{$args{'opts'}} if defined $args{'opts'}; + +my $model = getModel($args{'bngl'}); +my $exec_params = getExecParams(\%args); +execute_params($model,$exec_params); + + +sub filecheck +{ + my $file = shift @_; + my $type = shift @_; + if(not defined $file) { print $type." file not defined.\n"; exit;} + if(not -e $file) { print $type." file ".$file." not found.\n"; exit;} + print "Found ".$type." file ".$file.".\n"; + return; +} + +sub getModel +{ + my $filename = shift @_; + print "Importing model from ".$filename."\n"; + my %args = (); + $args{'file'} = $filename; + $args{'skip_actions'} = 1; + $args{'action_skip_warn'} = 1; + + #print $filename; + my $model = BNGModel->new(); + $model->initialize(); + $BNGModel::GLOBAL_MODEL = $model; + + #print "Opening file: ".$filename."\n"; + my $err = $model->readModel(\%args) ; + + if ($err) { print "ERROR:".$err."\n";} + + return $model; +} + +sub display_help +{ + print qq{ +---------------------------------------------/ HELP MENU /---------- +SYNOPSIS: + + visualize.pl --help show this help menu + visualize.pl --bngl MODEL --type TYPE make visualization of type TYPE for bngl model MODEL + TYPE "regulatory" is used as default if --type is not used. + + ----------------------- + Allowed values for TYPE + ----------------------- + conventional conventional rule visualization + compact compact rule visualization (using graph operation nodes) + regulatory rule-derived regulatory graph + opts options template for regulatory graph + contactmap contact map + reaction_network reaction network + +OPTIONS: + + -------------- + Common Options + -------------- + --suffix STR add suffix STR to output filename + + -------------------------------------------------------- + Options for TYPE "conventional", "compact", "regulatory" + -------------------------------------------------------- + --each show all rules in separate GML files (default: 0) + + ----------------------------- + Options for TYPE "regulatory" + ----------------------------- + --opts FILE import options file named FILE + --opts FILE1 --opts FILE2 import multiple options files + --background enable background (default: disabled) + --groups enable groups (default: disabled) + --collapse enable collapsing of groups (default: disabled) + --ruleNames enable display of rule names (default: disabled) + --doNotUseContextWhenGrouping use permissive edge signature (default: strict) + --doNotCollapseEdges when collapsing nodes, retain duplicate edges (default: removed) + +NOTES: + (i) To obtain a template options file for a model, use TYPE "opts". + You can edit this file and import it as --opts FILE. + (ii) To obtain full model regulatory graph, use --background and all other options set to default. + (iii) To show rule names and rule group names on the regulatory graph, use --ruleNames. + + } + +} + + + +sub display_help_old +{ + + print qq{ +---------------------------------------------/ HELP MENU /---------- + +SYNOPSIS: + + visualize.pl --help show this help menu + visualize.pl --type TYPE make visualization of type TYPE + + Allowed types: {ruleviz_pattern, ruleviz_operation, regulatory, contactmap } + Default type when --type is not used: regulatory + +OPTIONS: + + File I/O + -------- + --bngl FILE use BNGL model file (required) + --opts FILE1 [--opts FILE2 [..]] use input options files FILE1 FILE2 .. (optional) + --suffix "STR" add suffix STR to output filename (optional) + +USAGE: + Visualizing individual rules + ---------------------------- + visualize.pl --type ruleviz_pattern|ruleviz_operation [--each] + + ruleviz_pattern: rules are visualized as bipartite graphs with embedded pattern graphs + ruleviz_operation: rules are visualized as pattern graphs with graph operation nodes + each: enable output of separate gml file for each rule + + Visualizing contact map + ----------------------- + visualize.pl --type contactmap + + Visualizing regulatory graphs of individual rules + ------------------------------------------------- + visualize.pl --type regulatory [--each] [--background] + + background: turning background on shows all nodes (default is background off) + each: enable output of a separate gml file for each rule + + Visualizing text-only regulatory graph of model + ----------------------------------------------- + visualize.pl --type regulatory --background --textonly + + Visualizing regulatory graph of model + ------------------------------------- + visualize.pl --type regulatory [--background] [--groups [--collapse]] [--filter --level INT] [--opts FILE1 [--opts FILE2 [..] ] ] + + background: turning background on shows all nodes (default is background off) + groups: enable automated grouping of rules and user-assisted grouping of patterns + collapse: replace groups of nodes by a single node representative node + filter: filter regulatory graph starting from seed nodes and traversing edges upto an integer level deep + opts: one or more options files + + groups, background and filter options can be defined in options files which have the following structure: + + begin background + begin include + + end include + + begin exclude + + end exclude + end background + + begin filter + + end filter + + begin classes + begin classname + + end classname + end classes + + is a whitespace-separated list of patterns. + 'classname' refers to arbitrary names for pattern classes. + All blocks are optional. + + Include and exclude blocks determine which patterns are + included and excluded in the list of background patterns. + Filter block is for listing seed nodes for filtering regulatory graph. + +}; + return ""; +} + diff --git a/libvcell/vcell_install/bionetgen/Perl2/XML/TreePP.pm b/libvcell/vcell_install/bionetgen/Perl2/XML/TreePP.pm new file mode 100644 index 0000000..04f8595 --- /dev/null +++ b/libvcell/vcell_install/bionetgen/Perl2/XML/TreePP.pm @@ -0,0 +1,1331 @@ +=head1 NAME + +XML::TreePP -- Pure Perl implementation for parsing/writing XML documents + +=head1 SYNOPSIS + +parse an XML document from file into hash tree: + + use XML::TreePP; + my $tpp = XML::TreePP->new(); + my $tree = $tpp->parsefile( "index.rdf" ); + print "Title: ", $tree->{"rdf:RDF"}->{item}->[0]->{title}, "\n"; + print "URL: ", $tree->{"rdf:RDF"}->{item}->[0]->{link}, "\n"; + +write an XML document as string from hash tree: + + use XML::TreePP; + my $tpp = XML::TreePP->new(); + my $tree = { rss => { channel => { item => [ { + title => "The Perl Directory", + link => "http://www.perl.org/", + }, { + title => "The Comprehensive Perl Archive Network", + link => "http://cpan.perl.org/", + } ] } } }; + my $xml = $tpp->write( $tree ); + print $xml; + +get a remote XML document by HTTP-GET and parse it into hash tree: + + use XML::TreePP; + my $tpp = XML::TreePP->new(); + my $tree = $tpp->parsehttp( GET => "http://use.perl.org/index.rss" ); + print "Title: ", $tree->{"rdf:RDF"}->{channel}->{title}, "\n"; + print "URL: ", $tree->{"rdf:RDF"}->{channel}->{link}, "\n"; + +get a remote XML document by HTTP-POST and parse it into hash tree: + + use XML::TreePP; + my $tpp = XML::TreePP->new( force_array => [qw( item )] ); + my $cgiurl = "http://search.hatena.ne.jp/keyword"; + my $keyword = "ajax"; + my $cgiquery = "mode=rss2&word=".$keyword; + my $tree = $tpp->parsehttp( POST => $cgiurl, $cgiquery ); + print "Link: ", $tree->{rss}->{channel}->{item}->[0]->{link}, "\n"; + print "Desc: ", $tree->{rss}->{channel}->{item}->[0]->{description}, "\n"; + +=head1 DESCRIPTION + +XML::TreePP module parses an XML document and expands it for a hash tree. +This generates an XML document from a hash tree as the opposite way around. +This is a pure Perl implementation and requires no modules depended. +This can also fetch and parse an XML document from remote web server +like the XMLHttpRequest object does at JavaScript language. + +=head1 EXAMPLES + +=head2 Parse XML file + +Sample XML document: + + + + Yasuhisa + Chizuko + + Shiori + Yusuke + Kairi + + + +Sample program to read a xml file and dump it: + + use XML::TreePP; + use Data::Dumper; + my $tpp = XML::TreePP->new(); + my $tree = $tpp->parsefile( "family.xml" ); + my $text = Dumper( $tree ); + print $text; + +Result dumped: + + $VAR1 = { + 'family' => { + '-name' => 'Kawasaki', + 'father' => 'Yasuhisa', + 'mother' => 'Chizuko', + 'children' => { + 'girl' => 'Shiori' + 'boy' => [ + 'Yusuke', + 'Kairi' + ], + } + } + }; + +Details: + + print $tree->{family}->{father}; # the father's given name. + +The prefix '-' is added on every attribute's name. + + print $tree->{family}->{"-name"}; # the family name of the family + +The array is used because the family has two boys. + + print $tree->{family}->{children}->{boy}->[1]; # The second boy's name + print $tree->{family}->{children}->{girl}; # The girl's name + +=head2 Text node and attributes: + +If a element has both of a text node and attributes +or both of a text node and other child nodes, +value of a text node is moved to C<#text> like child nodes. + + use XML::TreePP; + use Data::Dumper; + my $tpp = XML::TreePP->new(); + my $source = 'Kawasaki Yusuke'; + my $tree = $tpp->parse( $source ); + my $text = Dumper( $tree ); + print $text; + +The result dumped is following: + + $VAR1 = { + 'span' => { + '-class' => 'author', + '#text' => 'Kawasaki Yusuke' + } + }; + +The special node name of C<#text> is used because this elements +has attribute(s) in addition to the text node. +See also L option. + +=head1 METHODS + +=head2 new + +This constructor method returns a new XML::TreePP object with C<%options>. + + $tpp = XML::TreePP->new( %options ); + +=head2 set + +This method sets a option value for C. +If C<$option_value> is not defined, its option is deleted. + + $tpp->set( option_name => $option_value ); + +See OPTIONS section below for details. + +=head2 get + +This method returns a current option value for C. + + $tpp->get( 'option_name' ); + +=head2 parse + +This method reads an XML document by string and returns a hash tree converted. +The first argument is a scalar or a reference to a scalar. + + $tree = $tpp->parse( $source ); + +=head2 parsefile + +This method reads an XML document by file and returns a hash tree converted. +The first argument is a filename. + + $tree = $tpp->parsefile( $file ); + +=head2 parsehttp + +This method receives an XML document from a remote server via HTTP and +returns a hash tree converted. + + $tree = $tpp->parsehttp( $method, $url, $body, $head ); + +C<$method> is a method of HTTP connection: GET/POST/PUT/DELETE +C<$url> is an URI of an XML file. +C<$body> is a request body when you use POST method. +C<$head> is a request headers as a hash ref. +L module or L module is required to fetch a file. + + ( $tree, $xml, $code ) = $tpp->parsehttp( $method, $url, $body, $head ); + +In array context, This method returns also raw XML document received +and HTTP response's status code. + +=head2 write + +This method parses a hash tree and returns an XML document as a string. + + $source = $tpp->write( $tree, $encode ); + +C<$tree> is a reference to a hash tree. + +=head2 writefile + +This method parses a hash tree and writes an XML document into a file. + + $tpp->writefile( $file, $tree, $encode ); + +C<$file> is a filename to create. +C<$tree> is a reference to a hash tree. + +=head1 OPTIONS FOR PARSING XML + +This module accepts option parameters following: + +=head2 force_array + +This option allows you to specify a list of element names which +should always be forced into an array representation. + + $tpp->set( force_array => [ 'rdf:li', 'item', '-xmlns' ] ); + +The default value is null, it means that context of the elements +will determine to make array or to keep it scalar or hash. +Note that the special wildcard name C<'*'> means all elements. + +=head2 force_hash + +This option allows you to specify a list of element names which +should always be forced into an hash representation. + + $tpp->set( force_hash => [ 'item', 'image' ] ); + +The default value is null, it means that context of the elements +will determine to make hash or to keep it scalar as a text node. +See also L option below. +Note that the special wildcard name C<'*'> means all elements. + +=head2 cdata_scalar_ref + +This option allows you to convert a cdata section into a reference +for scalar on parsing an XML document. + + $tpp->set( cdata_scalar_ref => 1 ); + +The default value is false, it means that each cdata section is converted into a scalar. + +=head2 user_agent + +This option allows you to specify a HTTP_USER_AGENT string which +is used by parsehttp() method. + + $tpp->set( user_agent => 'Mozilla/4.0 (compatible; ...)' ); + +The default string is C<'XML-TreePP/#.##'>, where C<'#.##'> is +substituted with the version number of this library. + +=head2 http_lite + +This option forces pasrsehttp() method to use a L instance. + + my $http = HTTP::Lite->new(); + $tpp->set( http_lite => $http ); + +=head2 lwp_useragent + +This option forces parsehttp() method to use a L instance. + + my $ua = LWP::UserAgent->new(); + $ua->timeout( 60 ); + $ua->env_proxy; + $tpp->set( lwp_useragent => $ua ); + +You may use this with L. + +=head2 base_class + +This blesses class name for each element's hashref. +Each class is named straight as a child class of it parent class. + + $tpp->set( base_class => 'MyElement' ); + my $xml = 'text'; + my $tree = $tpp->parse( $xml ); + print ref $tree->{root}->{parent}->{child}, "\n"; + +A hash for element above is blessed to C +class. You may use this with L. + +=head2 elem_class + +This blesses class name for each element's hashref. +Each class is named horizontally under the direct child of C. + + $tpp->set( base_class => 'MyElement' ); + my $xml = 'text'; + my $tree = $tpp->parse( $xml ); + print ref $tree->{root}->{parent}->{child}, "\n"; + +A hash for element above is blessed to C class. + +=head2 xml_deref + +This option dereferences the numeric character references, like ë, +漢, etc., in an XML document when this value is true. + + $tpp->set( xml_deref => 1 ); + +Note that, for security reasons and your convenient, +this module dereferences the predefined character entity references, +&, <, >, ' and ", and the numeric character +references up to U+007F without xml_deref per default. + +=head2 require_xml_decl + +This option requires XML declaration at the top of XML document to parse. + + $tpp->set( require_xml_decl => 1 ); + +This will die when declration not found. + +=head1 OPTIONS FOR WRITING XML + +=head2 first_out + +This option allows you to specify a list of element/attribute +names which should always appears at first on output XML document. + + $tpp->set( first_out => [ 'link', 'title', '-type' ] ); + +The default value is null, it means alphabetical order is used. + +=head2 last_out + +This option allows you to specify a list of element/attribute +names which should always appears at last on output XML document. + + $tpp->set( last_out => [ 'items', 'item', 'entry' ] ); + +=head2 indent + +This makes the output more human readable by indenting appropriately. + + $tpp->set( indent => 2 ); + +This doesn't strictly follow the XML specification but does looks nice. + +=head2 xml_decl + +This module inserts an XML declaration on top of the XML document generated +per default. This option forces to change it to another or just remove it. + + $tpp->set( xml_decl => '' ); + +=head2 output_encoding + +This option allows you to specify a encoding of the XML document generated +by write/writefile methods. + + $tpp->set( output_encoding => 'UTF-8' ); + +On Perl 5.8.0 and later, you can select it from every +encodings supported by Encode.pm. On Perl 5.6.x and before with +Jcode.pm, you can use C, C, C and +C. The default value is C which is recommended encoding. + +=head1 OPTIONS FOR BOTH + +=head2 utf8_flag + +This makes utf8 flag on for every element's value parsed +and makes it on for the XML document generated as well. + + $tpp->set( utf8_flag => 1 ); + +Perl 5.8.1 or later is required to use this. + +=head2 attr_prefix + +This option allows you to specify a prefix character(s) which +is inserted before each attribute names. + + $tpp->set( attr_prefix => '@' ); + +The default character is C<'-'>. +Or set C<'@'> to access attribute values like E4X, ECMAScript for XML. +Zero-length prefix C<''> is available as well, it means no prefix is added. + +=head2 text_node_key + +This option allows you to specify a hash key for text nodes. + + $tpp->set( text_node_key => '#text' ); + +The default key is C<#text>. + +=head2 ignore_error + +This module calls Carp::croak function on an error per default. +This option makes all errors ignored and just returns. + + $tpp->set( ignore_error => 1 ); + +=head2 use_ixhash + +This option keeps the order for each element appeared in XML. +L module is required. + + $tpp->set( use_ixhash => 1 ); + +This makes parsing performance slow. +(about 100% slower than default) + +=head1 AUTHOR + +Yusuke Kawasaki, http://www.kawa.net/ + +=head1 COPYRIGHT + +The following copyright notice applies to all the files provided in +this distribution, including binary files, unless explicitly noted +otherwise. + +Copyright 2006-2010 Yusuke Kawasaki + +=head1 LICENSE + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=cut + +package XML::TreePP; +use strict; +use Carp; +use Symbol; + +use vars qw( $VERSION ); +$VERSION = '0.41'; + +my $XML_ENCODING = 'UTF-8'; +my $INTERNAL_ENCODING = 'UTF-8'; +my $USER_AGENT = 'XML-TreePP/'.$VERSION.' '; +my $ATTR_PREFIX = '-'; +my $TEXT_NODE_KEY = '#text'; +my $USE_ENCODE_PM = ( $] >= 5.008 ); +my $ALLOW_UTF8_FLAG = ( $] >= 5.008001 ); + +sub new { + my $package = shift; + my $self = {@_}; + bless $self, $package; + $self; +} + +sub die { + my $self = shift; + my $mess = shift; + return if $self->{ignore_error}; + Carp::croak $mess; +} + +sub warn { + my $self = shift; + my $mess = shift; + return if $self->{ignore_error}; + Carp::carp $mess; +} + +sub set { + my $self = shift; + my $key = shift; + my $val = shift; + if ( defined $val ) { + $self->{$key} = $val; + } + else { + delete $self->{$key}; + } +} + +sub get { + my $self = shift; + my $key = shift; + $self->{$key} if exists $self->{$key}; +} + +sub writefile { + my $self = shift; + my $file = shift; + my $tree = shift or return $self->die( 'Invalid tree' ); + my $encode = shift; + return $self->die( 'Invalid filename' ) unless defined $file; + my $text = $self->write( $tree, $encode ); + if ( $ALLOW_UTF8_FLAG && utf8::is_utf8( $text ) ) { + utf8::encode( $text ); + } + $self->write_raw_xml( $file, $text ); +} + +sub write { + my $self = shift; + my $tree = shift or return $self->die( 'Invalid tree' ); + my $from = $self->{internal_encoding} || $INTERNAL_ENCODING; + my $to = shift || $self->{output_encoding} || $XML_ENCODING; + my $decl = $self->{xml_decl}; + $decl = '' unless defined $decl; + + local $self->{__first_out}; + if ( exists $self->{first_out} ) { + my $keys = $self->{first_out}; + $keys = [$keys] unless ref $keys; + $self->{__first_out} = { map { $keys->[$_] => $_ } 0 .. $#$keys }; + } + + local $self->{__last_out}; + if ( exists $self->{last_out} ) { + my $keys = $self->{last_out}; + $keys = [$keys] unless ref $keys; + $self->{__last_out} = { map { $keys->[$_] => $_ } 0 .. $#$keys }; + } + + my $tnk = $self->{text_node_key} if exists $self->{text_node_key}; + $tnk = $TEXT_NODE_KEY unless defined $tnk; + local $self->{text_node_key} = $tnk; + + my $apre = $self->{attr_prefix} if exists $self->{attr_prefix}; + $apre = $ATTR_PREFIX unless defined $apre; + local $self->{__attr_prefix_len} = length($apre); + local $self->{__attr_prefix_rex} = $apre; + + local $self->{__indent}; + if ( exists $self->{indent} && $self->{indent} ) { + $self->{__indent} = ' ' x $self->{indent}; + } + + if ( ! UNIVERSAL::isa( $tree, 'HASH' )) { + return $self->die( 'Invalid tree' ); + } + + my $text = $self->hash_to_xml( undef, $tree ); + if ( $from && $to ) { + my $stat = $self->encode_from_to( \$text, $from, $to ); + return $self->die( "Unsupported encoding: $to" ) unless $stat; + } + + return $text if ( $decl eq '' ); + join( "\n", $decl, $text ); +} + +sub parsehttp { + my $self = shift; + + local $self->{__user_agent}; + if ( exists $self->{user_agent} ) { + my $agent = $self->{user_agent}; + $agent .= $USER_AGENT if ( $agent =~ /\s$/s ); + $self->{__user_agent} = $agent if ( $agent ne '' ); + } else { + $self->{__user_agent} = $USER_AGENT; + } + + my $http = $self->{__http_module}; + unless ( $http ) { + $http = $self->find_http_module(@_); + $self->{__http_module} = $http; + } + if ( $http eq 'LWP::UserAgent' ) { + return $self->parsehttp_lwp(@_); + } + elsif ( $http eq 'HTTP::Lite' ) { + return $self->parsehttp_lite(@_); + } + else { + return $self->die( "LWP::UserAgent or HTTP::Lite is required: $_[1]" ); + } +} + +sub find_http_module { + my $self = shift || {}; + + if ( exists $self->{lwp_useragent} && ref $self->{lwp_useragent} ) { + return 'LWP::UserAgent' if defined $LWP::UserAgent::VERSION; + return 'LWP::UserAgent' if &load_lwp_useragent(); + return $self->die( "LWP::UserAgent is required: $_[1]" ); + } + + if ( exists $self->{http_lite} && ref $self->{http_lite} ) { + return 'HTTP::Lite' if defined $HTTP::Lite::VERSION; + return 'HTTP::Lite' if &load_http_lite(); + return $self->die( "HTTP::Lite is required: $_[1]" ); + } + + return 'LWP::UserAgent' if defined $LWP::UserAgent::VERSION; + return 'HTTP::Lite' if defined $HTTP::Lite::VERSION; + return 'LWP::UserAgent' if &load_lwp_useragent(); + return 'HTTP::Lite' if &load_http_lite(); + return $self->die( "LWP::UserAgent or HTTP::Lite is required: $_[1]" ); +} + +sub load_lwp_useragent { + return $LWP::UserAgent::VERSION if defined $LWP::UserAgent::VERSION; + local $@; + eval { require LWP::UserAgent; }; + $LWP::UserAgent::VERSION; +} + +sub load_http_lite { + return $HTTP::Lite::VERSION if defined $HTTP::Lite::VERSION; + local $@; + eval { require HTTP::Lite; }; + $HTTP::Lite::VERSION; +} + +sub load_tie_ixhash { + return $Tie::IxHash::VERSION if defined $Tie::IxHash::VERSION; + local $@; + eval { require Tie::IxHash; }; + $Tie::IxHash::VERSION; +} + +sub parsehttp_lwp { + my $self = shift; + my $method = shift or return $self->die( 'Invalid HTTP method' ); + my $url = shift or return $self->die( 'Invalid URL' ); + my $body = shift; + my $header = shift; + + my $ua = $self->{lwp_useragent} if exists $self->{lwp_useragent}; + if ( ! ref $ua ) { + $ua = LWP::UserAgent->new(); + $ua->timeout(10); + $ua->env_proxy(); + $ua->agent( $self->{__user_agent} ) if defined $self->{__user_agent}; + } else { + $ua->agent( $self->{__user_agent} ) if exists $self->{user_agent}; + } + + my $req = HTTP::Request->new( $method, $url ); + my $ct = 0; + if ( ref $header ) { + foreach my $field ( sort keys %$header ) { + my $value = $header->{$field}; + $req->header( $field => $value ); + $ct ++ if ( $field =~ /^Content-Type$/i ); + } + } + if ( defined $body && ! $ct ) { + $req->header( 'Content-Type' => 'application/x-www-form-urlencoded' ); + } + $req->content($body) if defined $body; + my $res = $ua->request($req); + my $code = $res->code(); + my $text; + if ( $res->can( 'decoded_content' )) { + $text = $res->decoded_content( charset => 'none' ); + } else { + $text = $res->content(); # less than LWP 5.802 + } + my $tree = $self->parse( \$text ) if $res->is_success(); + wantarray ? ( $tree, $text, $code ) : $tree; +} + +sub parsehttp_lite { + my $self = shift; + my $method = shift or return $self->die( 'Invalid HTTP method' ); + my $url = shift or return $self->die( 'Invalid URL' ); + my $body = shift; + my $header = shift; + + my $http = HTTP::Lite->new(); + $http->method($method); + my $ua = 0; + if ( ref $header ) { + foreach my $field ( sort keys %$header ) { + my $value = $header->{$field}; + $http->add_req_header( $field, $value ); + $ua ++ if ( $field =~ /^User-Agent$/i ); + } + } + if ( defined $self->{__user_agent} && ! $ua ) { + $http->add_req_header( 'User-Agent', $self->{__user_agent} ); + } + $http->{content} = $body if defined $body; + my $code = $http->request($url) or return; + my $text = $http->body(); + my $tree = $self->parse( \$text ); + wantarray ? ( $tree, $text, $code ) : $tree; +} + +sub parsefile { + my $self = shift; + my $file = shift; + return $self->die( 'Invalid filename' ) unless defined $file; + my $text = $self->read_raw_xml($file); + $self->parse( \$text ); +} + +sub parse { + my $self = shift; + my $text = ref $_[0] ? ${$_[0]} : $_[0]; + return $self->die( 'Null XML source' ) unless defined $text; + + my $from = &xml_decl_encoding(\$text) || $XML_ENCODING; + my $to = $self->{internal_encoding} || $INTERNAL_ENCODING; + if ( $from && $to ) { + my $stat = $self->encode_from_to( \$text, $from, $to ); + return $self->die( "Unsupported encoding: $from" ) unless $stat; + } + + local $self->{__force_array}; + local $self->{__force_array_all}; + if ( exists $self->{force_array} ) { + my $force = $self->{force_array}; + $force = [$force] unless ref $force; + $self->{__force_array} = { map { $_ => 1 } @$force }; + $self->{__force_array_all} = $self->{__force_array}->{'*'}; + } + + local $self->{__force_hash}; + local $self->{__force_hash_all}; + if ( exists $self->{force_hash} ) { + my $force = $self->{force_hash}; + $force = [$force] unless ref $force; + $self->{__force_hash} = { map { $_ => 1 } @$force }; + $self->{__force_hash_all} = $self->{__force_hash}->{'*'}; + } + + my $tnk = $self->{text_node_key} if exists $self->{text_node_key}; + $tnk = $TEXT_NODE_KEY unless defined $tnk; + local $self->{text_node_key} = $tnk; + + my $apre = $self->{attr_prefix} if exists $self->{attr_prefix}; + $apre = $ATTR_PREFIX unless defined $apre; + local $self->{attr_prefix} = $apre; + + if ( exists $self->{use_ixhash} && $self->{use_ixhash} ) { + return $self->die( "Tie::IxHash is required." ) unless &load_tie_ixhash(); + } + + # Avoid segfaults when receving random input (RT #42441) + if ( exists $self->{require_xml_decl} && $self->{require_xml_decl} ) { + return $self->die( "XML declaration not found" ) unless looks_like_xml(\$text); + } + + my $flat = $self->xml_to_flat(\$text); + my $class = $self->{base_class} if exists $self->{base_class}; + my $tree = $self->flat_to_tree( $flat, '', $class ); + if ( ref $tree ) { + if ( defined $class ) { + bless( $tree, $class ); + } + elsif ( exists $self->{elem_class} && $self->{elem_class} ) { + bless( $tree, $self->{elem_class} ); + } + } + wantarray ? ( $tree, $text ) : $tree; +} + +sub xml_to_flat { + my $self = shift; + my $textref = shift; # reference + my $flat = []; + my $prefix = $self->{attr_prefix}; + my $ixhash = ( exists $self->{use_ixhash} && $self->{use_ixhash} ); + + my $deref = \&xml_unescape; + my $xml_deref = ( exists $self->{xml_deref} && $self->{xml_deref} ); + if ( $xml_deref ) { + if (( exists $self->{utf8_flag} && $self->{utf8_flag} ) || + ( $ALLOW_UTF8_FLAG && utf8::is_utf8( $$textref ))) { + $deref = \&xml_deref_string; + } else { + $deref = \&xml_deref_octet; + } + } + + while ( $$textref =~ m{ + ([^<]*) < + (( + \? ([^<>]*) \? + )|( + \!\[CDATA\[(.*?)\]\] + )|( + \!DOCTYPE\s+([^\[\]<>]*(?:\[.*?\]\s*)?) + )|( + \!--(.*?)-- + )|( + ([^\!\?\s<>](?:"[^"]*"|'[^']*'|[^"'<>])*) + )) + > ([^<]*) + }sxg ) { + my ( + $ahead, $match, $typePI, $contPI, $typeCDATA, + $contCDATA, $typeDocT, $contDocT, $typeCmnt, $contCmnt, + $typeElem, $contElem, $follow + ) + = ( $1, $2, $3, $4, $5, $6, $7, $8, $9, $10, $11, $12, $13 ); + if ( defined $ahead && $ahead =~ /\S/ ) { + $ahead =~ s/([^\040-\076])/sprintf("\\x%02X",ord($1))/eg; + $self->warn( "Invalid string: [$ahead] before <$match>" ); + } + + if ($typeElem) { # Element + my $node = {}; + if ( $contElem =~ s#^/## ) { + $node->{endTag}++; + } + elsif ( $contElem =~ s#/$## ) { + $node->{emptyTag}++; + } + else { + $node->{startTag}++; + } + $node->{tagName} = $1 if ( $contElem =~ s#^(\S+)\s*## ); + unless ( $node->{endTag} ) { + my $attr; + while ( $contElem =~ m{ + ([^\s\=\"\']+)\s*=\s*(?:(")(.*?)"|'(.*?)') + }sxg ) { + my $key = $1; + my $val = &$deref( $2 ? $3 : $4 ); + if ( ! ref $attr ) { + $attr = {}; + tie( %$attr, 'Tie::IxHash' ) if $ixhash; + } + $attr->{$prefix.$key} = $val; + } + $node->{attributes} = $attr if ref $attr; + } + push( @$flat, $node ); + } + elsif ($typeCDATA) { ## CDATASection + if ( exists $self->{cdata_scalar_ref} && $self->{cdata_scalar_ref} ) { + push( @$flat, \$contCDATA ); # as reference for scalar + } + else { + push( @$flat, $contCDATA ); # as scalar like text node + } + } + elsif ($typeCmnt) { # Comment (ignore) + } + elsif ($typeDocT) { # DocumentType (ignore) + } + elsif ($typePI) { # ProcessingInstruction (ignore) + } + else { + $self->warn( "Invalid Tag: <$match>" ); + } + if ( $follow =~ /\S/ ) { # text node + my $val = &$deref($follow); + push( @$flat, $val ); + } + } + $flat; +} + +sub flat_to_tree { + my $self = shift; + my $source = shift; + my $parent = shift; + my $class = shift; + my $tree = {}; + my $text = []; + + if ( exists $self->{use_ixhash} && $self->{use_ixhash} ) { + tie( %$tree, 'Tie::IxHash' ); + } + + while ( scalar @$source ) { + my $node = shift @$source; + if ( !ref $node || UNIVERSAL::isa( $node, "SCALAR" ) ) { + push( @$text, $node ); # cdata or text node + next; + } + my $name = $node->{tagName}; + if ( $node->{endTag} ) { + last if ( $parent eq $name ); + return $self->die( "Invalid tag sequence: <$parent>" ); + } + my $elem = $node->{attributes}; + my $forcehash = $self->{__force_hash_all} || $self->{__force_hash}->{$name}; + my $subclass; + if ( defined $class ) { + my $escname = $name; + $escname =~ s/\W/_/sg; + $subclass = $class.'::'.$escname; + } + if ( $node->{startTag} ) { # recursive call + my $child = $self->flat_to_tree( $source, $name, $subclass ); + next unless defined $child; + my $hasattr = scalar keys %$elem if ref $elem; + if ( UNIVERSAL::isa( $child, "HASH" ) ) { + if ( $hasattr ) { + # some attributes and some child nodes + %$elem = ( %$elem, %$child ); + } + else { + # some child nodes without attributes + $elem = $child; + } + } + else { + if ( $hasattr ) { + # some attributes and text node + $elem->{$self->{text_node_key}} = $child; + } + elsif ( $forcehash ) { + # only text node without attributes + $elem = { $self->{text_node_key} => $child }; + } + else { + # text node without attributes + $elem = $child; + } + } + } + elsif ( $forcehash && ! ref $elem ) { + $elem = {}; + } + # bless to a class by base_class or elem_class + if ( ref $elem && UNIVERSAL::isa( $elem, "HASH" ) ) { + if ( defined $subclass ) { + bless( $elem, $subclass ); + } elsif ( exists $self->{elem_class} && $self->{elem_class} ) { + my $escname = $name; + $escname =~ s/\W/_/sg; + my $elmclass = $self->{elem_class}.'::'.$escname; + bless( $elem, $elmclass ); + } + } + # next unless defined $elem; + $tree->{$name} ||= []; + push( @{ $tree->{$name} }, $elem ); + } + if ( ! $self->{__force_array_all} ) { + foreach my $key ( keys %$tree ) { + next if $self->{__force_array}->{$key}; + next if ( 1 < scalar @{ $tree->{$key} } ); + $tree->{$key} = shift @{ $tree->{$key} }; + } + } + my $haschild = scalar keys %$tree; + if ( scalar @$text ) { + if ( scalar @$text == 1 ) { + # one text node (normal) + $text = shift @$text; + } + elsif ( ! scalar grep {ref $_} @$text ) { + # some text node splitted + $text = join( '', @$text ); + } + else { + # some cdata node + my $join = join( '', map {ref $_ ? $$_ : $_} @$text ); + $text = \$join; + } + if ( $haschild ) { + # some child nodes and also text node + $tree->{$self->{text_node_key}} = $text; + } + else { + # only text node without child nodes + $tree = $text; + } + } + elsif ( ! $haschild ) { + # no child and no text + $tree = ""; + } + $tree; +} + +sub hash_to_xml { + my $self = shift; + my $name = shift; + my $hash = shift; + my $out = []; + my $attr = []; + my $allkeys = [ keys %$hash ]; + my $fo = $self->{__first_out} if ref $self->{__first_out}; + my $lo = $self->{__last_out} if ref $self->{__last_out}; + my $firstkeys = [ sort { $fo->{$a} <=> $fo->{$b} } grep { exists $fo->{$_} } @$allkeys ] if ref $fo; + my $lastkeys = [ sort { $lo->{$a} <=> $lo->{$b} } grep { exists $lo->{$_} } @$allkeys ] if ref $lo; + $allkeys = [ grep { ! exists $fo->{$_} } @$allkeys ] if ref $fo; + $allkeys = [ grep { ! exists $lo->{$_} } @$allkeys ] if ref $lo; + unless ( exists $self->{use_ixhash} && $self->{use_ixhash} ) { + $allkeys = [ sort @$allkeys ]; + } + my $prelen = $self->{__attr_prefix_len}; + my $pregex = $self->{__attr_prefix_rex}; + my $textnk = $self->{text_node_key}; + + foreach my $keys ( $firstkeys, $allkeys, $lastkeys ) { + next unless ref $keys; + my $elemkey = $prelen ? [ grep { substr($_,0,$prelen) ne $pregex } @$keys ] : $keys; + my $attrkey = $prelen ? [ grep { substr($_,0,$prelen) eq $pregex } @$keys ] : []; + + foreach my $key ( @$elemkey ) { + my $val = $hash->{$key}; + if ( !defined $val ) { + next if ($key eq $textnk); + push( @$out, "<$key />" ); + } + elsif ( UNIVERSAL::isa( $val, 'HASH' ) ) { + my $child = $self->hash_to_xml( $key, $val ); + push( @$out, $child ); + } + elsif ( UNIVERSAL::isa( $val, 'ARRAY' ) ) { + my $child = $self->array_to_xml( $key, $val ); + push( @$out, $child ); + } + elsif ( UNIVERSAL::isa( $val, 'SCALAR' ) ) { + my $child = $self->scalaref_to_cdata( $key, $val ); + push( @$out, $child ); + } + else { + my $ref = ref $val; + $self->warn( "Unsupported reference type: $ref in $key" ) if $ref; + my $child = $self->scalar_to_xml( $key, $val ); + push( @$out, $child ); + } + } + + foreach my $key ( @$attrkey ) { + my $name = substr( $key, $prelen ); + my $val = &xml_escape( $hash->{$key} ); + push( @$attr, ' ' . $name . '="' . $val . '"' ); + } + } + my $jattr = join( '', @$attr ); + + if ( defined $name && scalar @$out && ! grep { ! /^{__indent} ) { + s/^(\s*<)/$self->{__indent}$1/mg foreach @$out; + } + unshift( @$out, "\n" ); + } + + my $text = join( '', @$out ); + if ( defined $name ) { + if ( scalar @$out ) { + $text = "<$name$jattr>$text\n"; + } + else { + $text = "<$name$jattr />\n"; + } + } + $text; +} + +sub array_to_xml { + my $self = shift; + my $name = shift; + my $array = shift; + my $out = []; + foreach my $val (@$array) { + if ( !defined $val ) { + push( @$out, "<$name />\n" ); + } + elsif ( UNIVERSAL::isa( $val, 'HASH' ) ) { + my $child = $self->hash_to_xml( $name, $val ); + push( @$out, $child ); + } + elsif ( UNIVERSAL::isa( $val, 'ARRAY' ) ) { + my $child = $self->array_to_xml( $name, $val ); + push( @$out, $child ); + } + elsif ( UNIVERSAL::isa( $val, 'SCALAR' ) ) { + my $child = $self->scalaref_to_cdata( $name, $val ); + push( @$out, $child ); + } + else { + my $ref = ref $val; + $self->warn( "Unsupported reference type: $ref in $name" ) if $ref; + my $child = $self->scalar_to_xml( $name, $val ); + push( @$out, $child ); + } + } + + my $text = join( '', @$out ); + $text; +} + +sub scalaref_to_cdata { + my $self = shift; + my $name = shift; + my $ref = shift; + my $data = defined $$ref ? $$ref : ''; + $data =~ s#(]])(>)#$1]]>'; + $text = "<$name>$text\n" if ( $name ne $self->{text_node_key} ); + $text; +} + +sub scalar_to_xml { + my $self = shift; + my $name = shift; + my $scalar = shift; + my $copy = $scalar; + my $text = &xml_escape($copy); + $text = "<$name>$text\n" if ( $name ne $self->{text_node_key} ); + $text; +} + +sub write_raw_xml { + my $self = shift; + my $file = shift; + my $fh = Symbol::gensym(); + open( $fh, ">$file" ) or return $self->die( "$! - $file" ); + print $fh @_; + close($fh); +} + +sub read_raw_xml { + my $self = shift; + my $file = shift; + my $fh = Symbol::gensym(); + open( $fh, $file ) or return $self->die( "$! - $file" ); + local $/ = undef; + my $text = <$fh>; + close($fh); + $text; +} + +sub looks_like_xml { + my $textref = shift; + my $args = ( $$textref =~ /^(?:\s*\xEF\xBB\xBF)?\s*<\?xml(\s+\S.*)\?>/s )[0]; + if ( ! $args ) { + return; + } + return $args; +} + +sub xml_decl_encoding { + my $textref = shift; + return unless defined $$textref; + my $args = looks_like_xml($textref) or return; + my $getcode = ( $args =~ /\s+encoding=(".*?"|'.*?')/ )[0] or return; + $getcode =~ s/^['"]//; + $getcode =~ s/['"]$//; + $getcode; +} + +sub encode_from_to { + my $self = shift; + my $txtref = shift or return; + my $from = shift or return; + my $to = shift or return; + + unless ( defined $Encode::EUCJPMS::VERSION ) { + $from = 'EUC-JP' if ( $from =~ /\beuc-?jp-?(win|ms)$/i ); + $to = 'EUC-JP' if ( $to =~ /\beuc-?jp-?(win|ms)$/i ); + } + + my $RE_IS_UTF8 = qr/^utf-?8$/i; + if ( $from =~ $RE_IS_UTF8 ) { + $$txtref =~ s/^\xEF\xBB\xBF//s; # UTF-8 BOM (Byte Order Mark) + } + + my $setflag = $self->{utf8_flag} if exists $self->{utf8_flag}; + if ( ! $ALLOW_UTF8_FLAG && $setflag ) { + return $self->die( "Perl 5.8.1 is required for utf8_flag: $]" ); + } + + if ( $USE_ENCODE_PM ) { + &load_encode(); + my $encver = ( $Encode::VERSION =~ /^([\d\.]+)/ )[0]; + my $check = ( $encver < 2.13 ) ? 0x400 : Encode::FB_XMLCREF(); + + my $encfrom = Encode::find_encoding($from) if $from; + return $self->die( "Unknown encoding: $from" ) unless ref $encfrom; + my $encto = Encode::find_encoding($to) if $to; + return $self->die( "Unknown encoding: $to" ) unless ref $encto; + + if ( $ALLOW_UTF8_FLAG && utf8::is_utf8( $$txtref ) ) { + if ( $to =~ $RE_IS_UTF8 ) { + # skip + } else { + $$txtref = $encto->encode( $$txtref, $check ); + } + } else { + $$txtref = $encfrom->decode( $$txtref ); + if ( $to =~ $RE_IS_UTF8 && $setflag ) { + # skip + } else { + $$txtref = $encto->encode( $$txtref, $check ); + } + } + } + elsif ( ( uc($from) eq 'ISO-8859-1' + || uc($from) eq 'US-ASCII' + || uc($from) eq 'LATIN-1' ) && uc($to) eq 'UTF-8' ) { + &latin1_to_utf8($txtref); + } + else { + my $jfrom = &get_jcode_name($from); + my $jto = &get_jcode_name($to); + return $to if ( uc($jfrom) eq uc($jto) ); + if ( $jfrom && $jto ) { + &load_jcode(); + if ( defined $Jcode::VERSION ) { + Jcode::convert( $txtref, $jto, $jfrom ); + } + else { + return $self->die( "Jcode.pm is required: $from to $to" ); + } + } + else { + return $self->die( "Encode.pm is required: $from to $to" ); + } + } + $to; +} + +sub load_jcode { + return if defined $Jcode::VERSION; + local $@; + eval { require Jcode; }; +} + +sub load_encode { + return if defined $Encode::VERSION; + local $@; + eval { require Encode; }; +} + +sub latin1_to_utf8 { + my $strref = shift; + $$strref =~ s{ + ([\x80-\xFF]) + }{ + pack( 'C2' => 0xC0|(ord($1)>>6),0x80|(ord($1)&0x3F) ) + }exg; +} + +sub get_jcode_name { + my $src = shift; + my $dst; + if ( $src =~ /^utf-?8$/i ) { + $dst = 'utf8'; + } + elsif ( $src =~ /^euc.*jp(-?(win|ms))?$/i ) { + $dst = 'euc'; + } + elsif ( $src =~ /^(shift.*jis|cp932|windows-31j)$/i ) { + $dst = 'sjis'; + } + elsif ( $src =~ /^iso-2022-jp/ ) { + $dst = 'jis'; + } + $dst; +} + +sub xml_escape { + my $str = shift; + return '' unless defined $str; + # except for TAB(\x09),CR(\x0D),LF(\x0A) + $str =~ s{ + ([\x00-\x08\x0B\x0C\x0E-\x1F\x7F]) + }{ + sprintf( '&#%d;', ord($1) ); + }gex; + $str =~ s/&(?!#(\d+;|x[\dA-Fa-f]+;))/&/g; + $str =~ s//>/g; + $str =~ s/'/'/g; + $str =~ s/"/"/g; + $str; +} + +sub xml_unescape { + my $str = shift; + my $map = {qw( quot " lt < gt > apos ' amp & )}; + $str =~ s{ + (&(?:\#(\d{1,3})|\#x([0-9a-fA-F]{1,2})|(quot|lt|gt|apos|amp));) + }{ + $4 ? $map->{$4} : &code_to_ascii( $3 ? hex($3) : $2, $1 ); + }gex; + $str; +} + +sub xml_deref_octet { + my $str = shift; + my $map = {qw( quot " lt < gt > apos ' amp & )}; + $str =~ s{ + (&(?:\#(\d{1,7})|\#x([0-9a-fA-F]{1,6})|(quot|lt|gt|apos|amp));) + }{ + $4 ? $map->{$4} : &code_to_utf8( $3 ? hex($3) : $2, $1 ); + }gex; + $str; +} + +sub xml_deref_string { + my $str = shift; + my $map = {qw( quot " lt < gt > apos ' amp & )}; + $str =~ s{ + (&(?:\#(\d{1,7})|\#x([0-9a-fA-F]{1,6})|(quot|lt|gt|apos|amp));) + }{ + $4 ? $map->{$4} : pack( U => $3 ? hex($3) : $2 ); + }gex; + $str; +} + +sub code_to_ascii { + my $code = shift; + if ( $code <= 0x007F ) { + return pack( C => $code ); + } + return shift if scalar @_; # default value + sprintf( '&#%d;', $code ); +} + +sub code_to_utf8 { + my $code = shift; + if ( $code <= 0x007F ) { + return pack( C => $code ); + } + elsif ( $code <= 0x07FF ) { + return pack( C2 => 0xC0|($code>>6), 0x80|($code&0x3F)); + } + elsif ( $code <= 0xFFFF ) { + return pack( C3 => 0xE0|($code>>12), 0x80|(($code>>6)&0x3F), 0x80|($code&0x3F)); + } + elsif ( $code <= 0x10FFFF ) { + return pack( C4 => 0xF0|($code>>18), 0x80|(($code>>12)&0x3F), 0x80|(($code>>6)&0x3F), 0x80|($code&0x3F)); + } + return shift if scalar @_; # default value + sprintf( '&#x%04X;', $code ); +} + +1; diff --git a/libvcell/vcell_install/bionetgen/Perl2/XMLReader.pm b/libvcell/vcell_install/bionetgen/Perl2/XMLReader.pm new file mode 100644 index 0000000..349bd37 --- /dev/null +++ b/libvcell/vcell_install/bionetgen/Perl2/XMLReader.pm @@ -0,0 +1,67 @@ +package XMLReader; + +use strict; +use warnings; + +use XML::TreePP; +use Data::Dumper; + + + +sub new{ + my ($class) = @_; + + my $self = { + _tree => XML::TreePP->new((force_hash=>['Model']))->parsefile($_[1]) + }; + bless $self, $class; + return $self; +} + +sub getParameters{ + my ($self) = @_; + return $self->{_tree}->{sbml}->{Model}->{ListOfParameters}->{Parameter}; +} + +sub getParameter{ + my ($self, $idx) = @_; + return $self->{_tree}->{sbml}->{Model}->{ListOfParameters}->{Parameter}->[$idx]; + +} + +sub getNumParameters{ + my ($self) = @_; + return $self->{_tree}->{sbml}->{Model}->{ListOfParameters}->{Parameter}; +} + +sub getMolecules{ + my ($self) = @_; + return $self->{_tree}->{sbml}->{Model}->{ListOfMoleculeTypes}->{MoleculeType} ; +} + +sub getSpecies{ + my ($self) = @_; + return $self->{_tree}->{sbml}->{Model}->{ListOfSpecies}->{Species}; +} + +sub getCompartments{ + my ($self) = @_; + return $self->{_tree}->{sbml}->{Model}->{ListOfCompartments}->{Compartment}; +} + +sub getReactionRules{ + my ($self) = @_; + return $self->{_tree}->{sbml}->{Model}->{ListOfReactionRules}->{ReactionRule}; +} + +sub getObservables{ + my ($self) = @_; + return $self->{_tree}->{sbml}->{Model}->{ListOfObservables}->{Observable}; +} + +sub getFunctions{ + my ($self) = @_; + return $self->{_tree}->{sbml}->{Model}->{ListOfFunctions}; +} + +1; diff --git a/libvcell/vcell_install/bionetgen/Perl2/auto_hpp.pl b/libvcell/vcell_install/bionetgen/Perl2/auto_hpp.pl new file mode 100755 index 0000000..7e7aa20 --- /dev/null +++ b/libvcell/vcell_install/bionetgen/Perl2/auto_hpp.pl @@ -0,0 +1,235 @@ +#!/usr/bin/perl +use strict; +use warnings; +# Find Perl2 Module directory: +# Look for environment variable BNGPATH. If not defined, try current directory. +use FindBin; +use File::Spec; +use lib $FindBin::RealBin; +use lib exists $ENV{'BNGPATH'} ? File::Spec->catdir( ($ENV{'BNGPATH'}), "Perl2" ) : $FindBin::RealBin; +# load Perl Modules +use List::Util ("sum"); +use Scalar::Util ("looks_like_number"); +use Getopt::Long; +# load BNG Module +use BNGModel; + + +unless (exists $ENV{'BNGPATH'}) +{ # set BNGPATH environment variable + my ($volume,$directories,$file) = File::Spec->splitpath( $FindBin::RealBin ); + my @dirs = File::Spec->splitdir( $directories ); + pop @dirs; # BNG executable script should be down one directory from here + $ENV{'BNGPATH'} = File::Spec->catpath( $volume, File::Spec->catdir(@dirs), '' ); +} + + +# process arguments +my $complex = 1; # complex bookkeeping +my $dt = 1; # time step +my $fprof = 0.01; # volume fraction for profiling +my $fsim = 0.1; # volume fraction for simulation +my $gml = 10000000; # global molecule limit +my $klump = 100000; # lumping rate +my $modelpath = ''; # path to bngl model file +my $nsteps = 20; # num sim steps +my $params = ''; # name of parameter file +my $threshold = 50; # lumping threshold +my $verbose = 0; # verbose output +GetOptions( "complex!" => \$complex, + "dt=f" => \$dt, + "fprof=f" => \$fprof, + "fsim=f" => \$fsim, + "gml=i" => \$gml, + "help" => sub { display_help(); exit(0); }, + "klump=f" => \$klump, + "model=s" => \$modelpath, + "nsteps=i" => \$nsteps, + "params=s" => \$params, + "threshold=f" => \$threshold, + "verbose" => \$verbose + ) +or die "Error in command line arguments"; + + +# check for mandatory switches +if ($modelpath eq '') { die "Missing mandatory 'model' argument"; } +# warn if extra arguments +if (@ARGV) { warn "Ignoring extra command line arguments"; } + +# check for positive arguments +if ($dt <= 0) { die "Argument 'dt' must be positive"; } +if ($fprof <= 0) { die "Argument 'fprof' must be positive"; } +if ($fsim <= 0) { die "Argument 'fsim' must be positive"; } +if ($gml < 1) { die "Argument 'gml' must be positive"; } +if ($klump <= 0) { die "Argument 'klump' must be positive"; } +if ($nsteps < 1) { die "Argument 'nsteps' must be positive"; } +if ($threshold < 0) { die "Argument 'threshold' must be non-negative"; } + + +# extract model prefix +my $model_prefix; +my ($vol,$dir,$file) = File::Spec->splitpath( $modelpath ); + +if ($file =~ /(.+)\.bngl$/) +{ $model_prefix = $1; } +else +{ die "Model file is does not have BNGL extension"; } + +# readfile options +my %readfile_params = ( "action_skip_warn"=>1, "allow_actions"=>0, "logging"=>"${model_prefix}.log" ); +# nfsim configuration +my %simulate_params = ( "suffix"=>"nf", "t_end"=>$dt, "n_steps"=>1, + "gml"=>$gml, "complex"=>$complex, "verbose"=>$verbose ); + +# read model +my $model = BNGModel->new(); +$model->initialize(); +my $err = $model->readFile({"file"=>$modelpath, %readfile_params}); +if ($err) { die "some problem reading model file: $err"; } + +# load parameters from file +if ($params ne '') +{ + my $err = $model->readFile({"file"=>$params, %readfile_params}); + if ($err) { die "some problem reading param file: $err"; } +} + +# set volume fraction +$err = $model->setParameter("f", $fprof); +if ($err) { die "some problem reading param file: $err"; } + +# open output files +my $runhpp_file = "run_${model_prefix}_hpp.bngl"; +open(HppFH,">",$runhpp_file) or die "Could not open file $runhpp_file"; + +# get initial populations +my %population_data = (); +$model->SpeciesList->checkOrInitConcentrations( $model->Concentrations ); +foreach my $species (@{$model->SpeciesList->Array}) +{ + my $species_idx = $species->Index; + my $species_pop = $model->Concentrations->[$species_idx-1]; + $species_pop = sprintf "%.0f", $model->ParamList->evaluate($species_pop); + $population_data{$species_idx} = [$species_pop]; +} + +# run simulations and collect species populations +print "[auto_hpp.pl] Running NFsim to profile species populations . . .\n"; +foreach my $iter (1 .. $nsteps) +{ + $model->simulate_nf( \%simulate_params ); + foreach my $species (@{$model->SpeciesList->Array}) + { + my $species_idx = $species->Index; + my $species_pop = $model->Concentrations->[$species_idx-1]; + $species_pop = sprintf "%.0f", $model->ParamList->evaluate($species_pop); + if (exists $population_data{$species_idx}) + { push @{$population_data{$species_idx}}, $species_pop; } + else + { $population_data{$species_idx} = [(0)x($iter), $species_pop]; } + } +} + +# select species for lumping +my $pop_species = select_species_for_lumping(\%population_data, $model->SpeciesList, $threshold*($fprof/$fsim)); +printf "[auto_hpp.pl] Found %d species with average population greater than threshold=%.0f\n", scalar @$pop_species, $threshold; +printf "[auto_hpp.pl] Writing HPP script to file '%s' . . .\n", $runhpp_file; + +# write run HPP file +my $tend = $dt*$nsteps; +print HppFH qq{# run HPP simulation of ${model_prefix} +version("2.2.4+") +setModelName("${model_prefix}") +readFile({file=>"${modelpath}",allow_actions=>0,skip_action_warn=>1}) +}; +if ($params ne '') +{ print HppFH "readFile({file=>\"${params}\",allow_actions=>0})\n"; } +print HppFH qq{# configure HPP +begin parameters + # volume fraction, no units + f $fsim + # population lumping rate, /time + klump $klump +end parameters +begin population maps +}; +foreach my $species_idx (sort {$a <=> $b} @$pop_species) +{ + my $species = $model->SpeciesList->lookup_by_index($species_idx); + my $species_string = $species->SpeciesGraph->toString(); + printf HppFH " %s -> P%04d() klump\n", $species_string, $species_idx; +} +print HppFH qq{end population maps +generate_hybrid_model({ suffix=>"hpp", overwrite=>1, verbose=>1, execute=>1,\\ + actions=>["simulate_nf({ t_end=>${tend}, n_steps=>${nsteps} ,gml=>${gml}, complex=>${complex} })"] }) +}; + +# all done +close(HppFH); +printf "[auto_hpp.pl] done.\n"; +exit(0); + + + +# pick species for lumping +sub select_species_for_lumping +{ + my ($popdata, $specieslist, $threshold) = @_; + my $pop_species = []; + my $avgpops = average_population($popdata); + while ( my ($species,$avgpop) = each %$avgpops ) + { + if ($avgpop > $threshold) + { push @$pop_species, $species; } + } + return $pop_species; +} + + +# compute average populations +sub average_population +{ + my ($popdata) = @_; + my $avgpops = {}; + while ( my ($species,$data) = each %$popdata ) + { $avgpops->{$species} = sum( @{$popdata->{$species}} ) / @{$popdata->{$species}}; } + return $avgpops; +} + +# display help +sub display_help +{ + # print usage: + print q{ +auto_hpp.pl: profile species populations and write script that runs +HPP simulation where species are lumped if their population exceeded a +threshold during profiling. The output script is named "run_MODEL.bngl". +To generate and execute the HPP model, call "BNG2.pl run_MODEL.bngl". + +USAGE: auto_hpp.pl --model FILE [OPTIONS] + auto_hpp.pl --help + +OPTIONS: + + --dt FLOAT : time step (default=1) + --fprof FLOAT : vol. fraction for profiling (default=0.01) + --fsim FLOAT : vol. fraction for HPP simulation (default=0.1) + --gml INT : global molecule limit (default=10000000) + --klump FLOAT : lumping rate constant (default=100000) + --no-complex : disable complex bookkeeping + --nsteps INT : number of steps (default=20) + --params FILE : load parameter values from FILE + --threshold FLOAT : population threshold for lumping (default=50) + --verbose : enable verbose output + +auto_hpp.pl must be able to find BNG modules! Set the environment variable +BNGPATH to the BioNetGen directory. + +Note: vol. fraction is set via model parameter "f". If the model does +not implement the parameter, the feature will not work. + +}; + +} + diff --git a/libvcell/vcell_install/bionetgen/Perl2/diff_net.pl b/libvcell/vcell_install/bionetgen/Perl2/diff_net.pl new file mode 100755 index 0000000..c871ccd --- /dev/null +++ b/libvcell/vcell_install/bionetgen/Perl2/diff_net.pl @@ -0,0 +1,443 @@ +#!/usr/bin/perl +# compare two BNGL network files: +# determines if (1) species set is different. +# (2) reaction set is different. +# no other comparisons are made! +# +# usage: diff_net.pl bngl1.net bngl2.net > output +# +# author: justin.s.hogg@gmail.com +# last modified: 19mar2009 +# +# note: script works correctly in testing, but has no been +# throughly validated. error checking is minimal. +# +# Current script will only work if reactions are specified +# using species indices (rather than strings generated by +# keyword "TextReaction"). +# +# Challenge: Different species string generators will produce non-matching results. +# We need a comparison method that is independent of the species string. +# Possibility: use SpeciesGraph module to read species string and use +# HNauty to generate strings. + +use warnings; +use strict; + +# use version $Id: SpeciesGraph.pm,v 1.23 2007/07/06 04:47:25 faeder Exp $ +# use SpeciesGraph; + + +# get bngl file names from command line +print "> comparing BNGL network files.\n"; +my ($file1, $file2) = @ARGV; + +# parse bngl files and return species list and reaction list +my ($slist1, $rlist1) = parse_bngl($file1); +my ($slist2, $rlist2) = parse_bngl($file2); + +# find unique species in each list +print "> comparing species sets.\n"; +my $print_unique_species = generate_print_unique( 'species', \&stringify_species ); +my ($unique_slist1, $unique_slist2) = compare_lists( $slist1, $slist2, + \&compare_species, $print_unique_species ); + +if (@$unique_slist1) +{ # foreach unique species, determine which rules create it. + print_yielding_reactions( $unique_slist1, $rlist1, 1 ); +} + +if (@$unique_slist2) +{ # foreach unique species, determine which rules create it. + print_yielding_reactions( $unique_slist2, $rlist2, 2 ); +} + +# if species set are identical, then check if reactions are identical +unless ( @$unique_slist1 or @$unique_slist2 ) +{ + print "> comparing reaction sets.\n"; + my $print_unique_rxns = generate_print_unique( 'reaction', \&stringify_reaction ); + + # map species set 2 into set 1 + my $smap = map_species( $slist1, $slist2 ); + + # translate reaction list 2 + my $rlist2 = translate_reactions( $rlist2, $smap ); + + # compare reactions + my ($unique_rlist1, $unique_rlist2) = compare_lists( $rlist1, $rlist2, + \&compare_reactions, $print_unique_rxns ); +} + +print "> done comparing network files.\n"; +exit 0; + + + + +### ------------------- ### +### accessory functions ### +### ------------------- ### + + +sub parse_bngl +# (\@species_list, \@reaction_list) = parse_bngl( $filename ) +# parse BNGL network file and generate species and reaction lists +{ + my $file = shift; + print "> parsing bngl file $file.\n"; + open( FILE, '<', $file ); + + my $species_list = []; + my $reaction_list = []; + + my $species_block = 0; + my $reaction_block = 0; + while ( my $line = ) + { + if ($species_block) + { + if ( $line =~ /^end species/ ) + { $species_block = 0; } + else + { + my ($idx, $species_string) = ( $line =~ /^\s*(\d+)\s+(\S+)/ ); + my $species = + { + 'index' => $idx, + 'string' => process_species_string($species_string), + }; + push @$species_list, $species; + } + } + elsif ($reaction_block) + { + if ( $line =~ /^end reactions/ ) + { $reaction_block = 0; } + else + { + my ($idx, $reactants, $products, $ratelaw, $rule) + = ( $line =~ /^\s*(\d+)\s+([\d,]+)\s+([\d,]+)\s+(\S+)\s+#(\w+)/ ); + my $rxn = + { + 'index' => $idx, + 'reactants' => [ split /,/, $reactants ], + 'products' => [ split /,/, $products ], + 'ratelaw' => $ratelaw, + 'rule' => $rule + }; + push @$reaction_list, $rxn; + } + } + elsif ( $line =~ /^begin species/ ) + { $species_block = 1; } + elsif ( $line =~ /^begin reactions/ ) + { $reaction_block = 1; } + } + + close FILE; + return ($species_list, $reaction_list); +} + + + + +sub process_species_string +# $new_string = process_species_string( $old_string ) +# sorts the molecules in a species alphabetically +{ + my $species_string = shift; +# my ($head) = ( $species_string =~ s/^([^+>]+::)\s*// ); +# my @molecules = ( split /\./, $species_string ); + + # reconstruct string in alpha-numeric ordering +# $species_string = $head; +# foreach my $molecule ( sort {$a cmp $b} @molecules ) +# { $species_string .= $molecule . '.'; } + + # remove trailing '.' +# chop $species_string; + + return $species_string; +} + + + + +sub compare_lists +# (\@unique_set1, \@unique_set2) = compare_lists( \@list1, \@list2, \&compare_fcn, \&print_fcn ) +# compares two lists and identified unique elements. +# &compare_fcn is a subroutine which compares elements in the lists (like cmp or <=>). +# &print_fcn is a subroutine which prints unique elements in the lists (see examples below). +{ + my ($list1, $list2, $compare_fcn, $print_fcn) = @_; + my $unique1 = []; + my $unique2 = []; + + # sort lists + @$list1 = ( sort $compare_fcn @$list1 ); + @$list2 = ( sort $compare_fcn @$list2 ); + + # compare lists + my $idx1 = 0; + my $idx2 = 0; + while ( $idx1 < @$list1 and $idx2 < @$list2 ) + { + my $compare = &$compare_fcn( $list1->[$idx1], $list2->[$idx2] ); + + if ( $compare == 0 ) + { # items are the same + $idx1++; + $idx2++; + } + elsif ( $compare == 1 ) + { # item on list2 is unique + push @$unique2, $list2->[$idx2]; + $idx2++; + } + elsif ( $compare == -1 ) + { # item on list1 is unique + push @$unique1, $list1->[$idx1]; + $idx1++; + } + } + + # everything remaining in $list1 is unique + while ( $idx1 < @$list1 ) + { + push @$unique1, $list1->[$idx1]; + $idx1++; + } + + # everything remaining in $list2 is unique + while ( $idx2 < @$list2 ) + { + push @$unique2, $list2->[$idx2]; + $idx2++; + } + + &$print_fcn( $unique1, $unique2 ); + return ($unique1, $unique2); +} + + + + +sub compare_species +# $int = compare_species( $sp1, $sp2 ) +# compares two species based on string representation. +# returns one of -1, 0, or 1. (like cmp) +{ + my ($s1, $s2); + + if ( defined $a and defined $b ) + { $s1 = $a; $s2 = $b; } + else + { ($s1, $s2) = @_; } + + return $s1->{string} cmp $s2->{string}; +} + + + + +sub compare_reactions +# $int = compare_reactions( $rxn1, $rxn2 ) +# compares two reactions based on reactants and products (only!). +# returns one of -1, 0, or 1. (like cmp) +{ + my ($r1, $r2); + + if ( defined $a and defined $b ) + { $r1 = $a; $r2 = $b; } + else + { ($r1, $r2) = @_; } + + my @array1 = ( sort {$a<=>$b} @{$r1->{reactants}}, -1, sort {$a<=>$b} @{$r1->{products}} ); + my @array2 = ( sort {$a<=>$b} @{$r2->{reactants}}, -1, sort {$a<=>$b} @{$r2->{products}} ); + + return compare_number_arrays( \@array1, \@array2 ); +} + + + + +sub compare_number_arrays +# $int = compare_number_arrays( $a1, $a2 ) +# compares two numeric arrays. longer arrays are "bigger". arrays of same length +# are compared element by element. The array with the larger element at the first +# difference is considered "bigger". +# returns one of -1, 0, or 1. (like cmp) +{ + my ($a1, $a2) = @_; + + my $cmp = scalar(@$a1) cmp scalar(@$a2); + if ($cmp) { return $cmp; } + + foreach my $idx ( 0 .. $#{$a1} ) + { + $cmp = $a1->[$idx] cmp $a2->[$idx]; + if ($cmp) { return $cmp; } + } + + # arrays are numerically the same + return 0; +} + + + + +sub generate_print_unique +# \&print_fcn = generate_print_unique( $type, $string_fcn ) +# generates an anonymous function that prints unique elements found in comparison. +{ + my ($type, $string_fcn) = @_; + + return sub + { + my ($list1, $list2) = @_; + + if ( @$list1 == 0 and @$list2 == 0 ) + { + print " ** $type sets are identical.\n" + } + else + { + printf " ** %s set1 has %u unique element(s).\n", $type, scalar(@$list1); + foreach my $item ( sort {$a->{'index'} <=> $b->{'index'}} @$list1 ) + { printf " %s\n", &{$string_fcn}($item); } + printf " ** %s set2 has %u unique element(s).\n", $type, scalar(@$list2); + foreach my $item ( sort {$a->{'index'} <=> $b->{'index'}} @$list2 ) + { printf " %s\n", &{$string_fcn}($item); } + } + return 0; + }; +} + + + + +sub stringify_reaction +# turn reaction hash into a string +{ + my $rxn = shift; + return sprintf( "%6d %s %s %s #%s", $rxn->{'index'}, join(',', @{$rxn->{reactants}}), + join(',', @{$rxn->{products}}), $rxn->{ratelaw}, $rxn->{rule} ); +} + + + + +sub stringify_species +# turn species hash into a string +{ + my $species = shift; + return sprintf( "%6d %s", $species->{'index'}, $species->{string} ); +} + + + + +sub print_yielding_reactions +# 0 = print_yielding_reactions( \@slist, \@rlist, $set_idx ) +# finds and prints reactions in @rlist which yield species in @slist. +# $set_idx is just an index for print display. +{ + my ($slist, $rlist, $set_idx) = @_; + print "> searching for reactions which yield unique species in set $set_idx.\n"; + foreach my $sp ( @$slist ) + { + printf " ** Reactions yielding species %s %s:\n", $sp->{'index'}, $sp->{string}; + my $ylist = find_yielding_reactions( $sp, $rlist ); + foreach my $rxn ( @$ylist ) + { printf " + reaction: % 6u rule: %s\n", $rxn->{'index'}, $rxn->{rule}; } + } + return 0; +} + + + + +sub find_yielding_reactions +# accessory to print_yielding_reactions +{ + my ($species, $rlist) = @_; + my $species_idx = $species->{'index'}; + my $ylist = []; + + foreach my $rxn ( @$rlist ) + { + if ( grep {$_ == $species_idx} @{$rxn->{products}} ) + { push @$ylist, $rxn; } + } + return $ylist; +} + + + + +sub map_species +# \%smap = map_species( \@slist1, \@slist2 ) +# map species indices in list1 to species indices in list2 +# (based on string comparison) +{ + my ($slist1, $slist2) = @_; + my $smap = {}; + + my $sdict1 = build_species_dictionary( $slist1 ); + my $sdict2 = build_species_dictionary( $slist2 ); + + foreach my $sp ( keys %$sdict1 ) + { + my $idx1 = $sdict1->{$sp}; + my $idx2 = $sdict2->{$sp}; + $smap->{$idx2} = $idx1; + } + return $smap; +} + + + + +sub build_species_dictionary +# \%sdict = build_species_dictionary( $slist ) +# build a map from species strings to indices. +{ + my $slist = shift; + my $sdict = {}; + + foreach my $sp (@$slist) + { $sdict->{ $sp->{string} } = $sp->{'index'}; } + return $sdict; +} + + + + +sub translate_reactions +# \@tlist = translate_reactions( \@rlist, \%smap ) +# translate a set of rules into a new indexing scheme +# as specified by %smap. +{ + my ($rlist, $smap) = @_; + + # create a container for translated lists; + my $tlist = []; + + foreach my $rxn (@$rlist) + { # copy and translate each reaction + my $trxn = {}; + %{$trxn} = %{$rxn}; + push @$tlist, $trxn; + + # translate reactions + foreach my $reac ( @{$trxn->{reactants}} ) + { $reac = $smap->{$reac}; } + + foreach my $prod ( @{$trxn->{products}} ) + { $prod = $smap->{$prod}; } + } + + return $tlist; +} + diff --git a/libvcell/vcell_install/bionetgen/Perl2/sample_vars_2.pl b/libvcell/vcell_install/bionetgen/Perl2/sample_vars_2.pl new file mode 100644 index 0000000..8cbd6f8 --- /dev/null +++ b/libvcell/vcell_install/bionetgen/Perl2/sample_vars_2.pl @@ -0,0 +1,571 @@ +#!/usr/bin/perl +# Simple parameter scanning script. Creates and runs a single BNGL file that +# scans a single parameter using the setParameter command". User provides +# a BNGL file containing the model - actions in this file are ignored. +# +# Written by Jim Faeder, Los Alamos National Laboratory, 3/6/2007 + +# Updated on 2 April 2012 by J.Hogg +# + checks environment variables BNGPATH and BioNetGenRoot for the BNG folder +# + now using File::Spec for platform independent path handling +# + output now written in current directory (not the model directory!) +# + This version requires BioNetGen version 2.2.0-testing + +# Additional updates by L. Harris (2012,2013) +# -method argument +# require 'begin/end model' +# -verbose argument +# various bug fixes + +use strict; +use warnings; + +# Perl Modules +use FindBin; +use lib $FindBin::RealBin; +use File::Spec; +use File::Path qw(remove_tree); +use Config; +use IO::Handle; +use IPC::Open3; +use POSIX; + +# Set up Signal Handlers.. +# define global variable to store PID of child process. +$::CHILD_PID = undef; +# Get signal names +my $i = 0; +my %SIGNO=(); +defined($Config{sig_name}) or die "No signals defined"; +foreach my $signame ( split " ", $Config{sig_name} ) +{ + $SIGNO{$signame} = $i; + $i++; +} +# TERM signal handler: make sure any child processes are shutdown before termination +$SIG{'TERM'} = sub +{ + if (defined $::CHILD_PID) + { # kill off child process + print "\n>>>relaying TERM signal to child with PID: ", $::CHILD_PID, " <<<\n"; + kill $SIGNO{"TERM"}, $::CHILD_PID; + } + die "BioNetGen received TERM signal"; +}; +# INT signal handler: make sure any child processes are shutdown before termination +$SIG{'INT'} = sub +{ + if (defined $::CHILD_PID) + { # kill off child process + print "\n>>> relaying INT signal to child with PID: ", $::CHILD_PID, " <<<\n"; + kill $SIGNO{"INT"}, $::CHILD_PID; + } + die "scan_var received INT signal"; +}; + + + +# get perl binary +my $perlbin = $^X; + +# get BNG path +my $bngpath; +my $bngexec; +{ + # try to find path in environment variables + $bngpath = (exists $ENV{'BNGPATH'} ? $ENV{'BNGPATH'} : + (exists $ENV{'BioNetGenRoot'} ? $ENV{'BioNetGenRoot'} : undef) ); + unless (defined $bngpath) + { # use FindBin to locate BNG + my ($volume,$directories,$file) = File::Spec->splitpath( $FindBin::RealBin ); + my @dirs = File::Spec->splitdir( $directories ); + pop @dirs; # BNG executable script should be down one directory from here + $bngpath = File::Spec->catpath( $volume, File::Spec->catdir(@dirs), '' ); + } + # define executable + $bngexec = File::Spec->catfile( $bngpath, "BNG2.pl" ); +} + +# some default parameters +my $log = 0; +my $t_end = 20; +my $n_steps = 1; +my $steady_state = 0; +my $method = "\"ode\""; +my $pla_output = 0; +my $verbose = 0; +my $samplingMethod = "\"random\""; +my $varMeasured = "\"end\""; +my $n_dims = 2; + +my $prefix; +my @mandatory_args = (); +while ( @ARGV ) +{ + my $arg = shift @ARGV; + if ( $arg =~ s/^(-{1,2})// ) + { + if ( $arg eq 'log' ){ + $log = 1; + } + elsif($arg eq 'n_steps'){ +# unless (@ARGV) { die "Syntax error: $arg requires value"; } + $n_steps = shift @ARGV; + if ($n_steps =~ /^-{1,2}/ || $n_steps =~ /\.bngl$/) + { die "Syntax error: '$arg' requires value"; } + } + elsif($arg eq 'prefix'){ +# unless (@ARGV) { die "Syntax error: $arg requires value"; } + $prefix = shift @ARGV; + if ($prefix =~ /^-{1,2}/ || $prefix =~ /\.bngl$/) + { die "Syntax error: '$arg' requires value"; } + } + elsif($arg eq 'steady_state'){ + $steady_state = 1; + } + elsif($arg eq 't_end'){ +# unless (@ARGV) { exit_error("Syntax error: $arg requires value"); } + $t_end = shift @ARGV; + if ($t_end =~ /^-{1,2}/ || $t_end =~ /\.bngl$/) + { die "Syntax error: '$arg' requires value"; } + } + elsif($arg eq 'method'){ + $method = shift @ARGV; + if ($method =~ /^-{1,2}/ || $method =~ /\.bngl$/) + { die "Syntax error: '$arg' requires value"; } + if ($method eq 'pla'){ + my $pla_config = shift @ARGV; + if ($pla_config =~ /^-{1,2}/ || $pla_config =~ /\.bngl$/) + { die "Syntax error: PLA simulator requires a simulation configuration: --method pla CONFIG. " . + "Please try again."; } + $method = "\"$method\",pla_config=>\"$pla_config\""; + } + else{ + $method = "\"$method\""; + } + } + elsif($arg eq 'pla_output'){ + $pla_output = 1; + } + elsif($arg eq 'verbose'){ + $verbose = 1; + } + elsif($arg eq 'help'){ + display_help(); + exit 0; + } + elsif($arg eq 'samplingMethod'){ + $samplingMethod = shift @ARGV; + if ($samplingMethod =~ /^-{1,2}/ || $samplingMethod =~ /\.bngl$/) + { die "Syntax error: '$arg' requires value"; } + $samplingMethod = "\"$samplingMethod\""; + } + elsif($arg eq 'varMeasured'){ + $varMeasured = shift @ARGV; + if ($varMeasured =~ /^-{1,2}/ || $varMeasured =~ /\.bngl$/) + { die "Syntax error: '$arg' requires value"; } + $varMeasured = "\"$varMeasured\""; + } + elsif($arg eq 'n_dims'){ + # unless (@ARGV) { die "Syntax error: $arg requires value"; } + $n_dims = shift @ARGV; + if ($n_dims =~ /^-{1,2}/ || $n_dims =~ /\.bngl$/) + { die "Syntax error: '$arg' requires value"; } + } + else{ + die "Syntax error: unrecognized command line option $arg"; + } + } + else + { # assume this is a mandatory argument + push @mandatory_args, $arg; + } +} +#print "args: ", join(',', @mandatory_args), "\n"; +unless (@mandatory_args== 2 + 3*$n_dims) +{ # complain about too few arguments + die "Syntax error: 8 required arguments (Try scan_var.pl --help)"; +} + +# get mandatory arguments +#my ($file, $var1, $var_min1, $var_max1, $var2, $var_min2, $var_max2, $n_pts) = @mandatory_args; +my $file = $mandatory_args[0]; +my $n_pts = $mandatory_args[1 + 3*$n_dims]; +my $offset; +my $division; +if ($samplingMethod eq "\"grid\"") { + $division = $n_pts - 1; + $n_pts = $n_pts**$n_dims +} +if ($samplingMethod eq "\"latin\"") { + $offset = 1; +} elsif ($samplingMethod eq "\"random\"" | $samplingMethod eq "\"grid\"") { + $offset = 3; +} +$n_pts += $offset; + + +# Automatic assignment of prefix if unset +unless ($prefix) +{ + # separate directories from filename (if any) + my ($volume,$directories,$file) = File::Spec->splitpath( $file ); + unless ( $file =~ /\.bngl$/ ) + { die "Cannot extract prefix from filename $file"; } + # trim bngl extension to define prefix + ($prefix = $file) =~ s/\.bngl$//; +} +# add variable name to prefix +for (my $i = 0; $i < $n_dims; $i++) { + my $var = $mandatory_args[3*$i + 1]; + $prefix.="_${var}"; +} + + +if ($log) +{ # convert min and max into log values + for (my $i = 0; $i < $n_dims; $i++) { + $mandatory_args[2 + 3*$i] = log($mandatory_args[2 + 3*$i]); + $mandatory_args[3 + 3*$i] = log($mandatory_args[3 + 3*$i]); + } +} + +# calculate parameter step +#my $delta; +#if ($var_max==$var_min){ +# $delta = 0; +#} +#else{ +# $delta = ($var_max-$var_min)/($n_pts-1); +#} + +# Read file +open(IN, $file) or die "Couldn't open file $file: $?\n"; +my $script = ""; +while ( my $line = ) +{ + $script .= $line; + # Skip actions + last if ($line =~ /^\s*end\s+model/); +} +close(IN); + +# Require 'end model' directive +if (!($script =~ /\n\s*end\s+model/)){ + die "ERROR: scan_var requires model to be enclosed in 'begin model' / 'end model' block."; +} + +# prepare working directory +if (-d $prefix) +{ # delete output directory + print "WARNING: overwriting existing work directory $prefix.\n"; + my $err; + remove_tree( $prefix, {'safe'=>1, 'keep_root'=>1, 'error'=> \$err} ); + if (@$err) + { die "Unable to delete files in work directory $prefix"; } +} +else +{ # make directory for output files + mkdir $prefix; +} + +# Create model file with scan actions +my $scanmodel = File::Spec->catfile( ${prefix}, "${prefix}.bngl" ); +my $logfile = File::Spec->catfile( ${prefix}, "${prefix}.log" ); + +open(BNGL,">", $scanmodel) or die "Couldn't open $scanmodel for output"; +print BNGL $script; +print BNGL "\n"; +print BNGL "generate_network({overwrite=>1})\n"; +print $script; +print "\n"; +print "generate_network({overwrite=>1})\n"; +my @vals; +my @val; + +{ + srand(5.014); + my @count = (0)x$n_dims; + foreach my $run (1..$n_pts) + { + if ($samplingMethod eq "\"random\"") { + for ($i = 0; $i < $n_dims; $i++) { + $val[$i] = $mandatory_args[3*$i + 2] + rand()*($mandatory_args[3*$i + 3]-$mandatory_args[3*$i + 2]); + } + } elsif ($samplingMethod eq "\"grid\"") { + if ($run == 1) { + for ($i = 0; $i < $n_dims; $i++) { + $val[$i] = $mandatory_args[3*$i + 2]; + } + } else { + my $carry = 1; + #my $division = ($n_pts - 3)**(1/$n_dims) - 1; + for ($i = 0; $i < $n_dims; $i++) { + if ($carry) { + #my $range = $mandatory_args[3*$i + 3]-$mandatory_args[3*$i + 2]; + #my $division = $n_pts**(1/$n_dims); + #my $increment = $range/$division; + #print("$range $division $increment\n"); + $val[$i] = $val[$i] + ($mandatory_args[3*$i + 3]-$mandatory_args[3*$i + 2])/$division; + $count[$i]++; + my $difference = $division - $count[$i]; + if ($count[$i] > $division) { + #$val[$i] = $val[$i] - ($mandatory_args[3*$i + 3]-$mandatory_args[3*$i + 2]); + $val[$i] = $mandatory_args[3*$i + 2]; + $count[$i] = 0; + } else { + $carry = 0; + } + } + } + } + } elsif ($samplingMethod eq "\"latin\"") { + for ($i = 0; $i < $n_dims; $i++) { + do { + $val[$i] = $mandatory_args[3*$i + 2] + ($mandatory_args[3*$i + 3] - $mandatory_args[3*$i + 2])*int(rand($n_pts))/$n_pts; + + } while (grep( /^$val[$i]$/, @{$vals[$i]})); + } + } + #print("$run "); + #foreach my $x (@val) { + # my $y = $log ? exp($x) : $x; + # printf "%16.8e", $y; + #} + #print("\n"); + #print("@val\n"); + push @vals, [@val]; + #print("$run @val\n"); + my $srun = sprintf "%05d", $run; + if ($run > 1){ + #print BNGL "resetConcentrations()\n"; + #print "resetConcentrations()\n"; + } + for my $i (0 .. $#val) { + my $x = $val[$i]; + my $var = $mandatory_args[3*$i + 1]; + if ($log){ $x = exp($x);} + #print("$x "); + printf BNGL "setParameter(\"$var\",%.12g)\n", $x; + printf "setParameter(\"$var\",%.12g)\n", $x; + } + my $opt = "method=>$method"; + if ($pla_output){ + $opt .= ",pla_output=>1"; + } + $opt .= ",suffix=>\"$srun\",t_end=>$t_end,n_steps=>$n_steps"; + if ($steady_state){ + $opt .= ",steady_state=>1"; + } + if ($verbose){ + $opt .= ",verbose=>1"; + } + printf BNGL "simulate({$opt})\n"; #"simulate_ode({$opt})\n"; + printf BNGL "resetConcentrations()\n"; + printf "simulate({$opt})\n"; #"simulate_ode({$opt})\n"; + printf "resetConcentrations()\n"; + } +} +close(BNGL); + + + + +# Run BioNetGen on ScanModel file +#print "Running BioNetGen on $scanmodel\n"; +my @command = ($perlbin, $bngexec, "--outdir", $prefix, $scanmodel); +print("@command\n"); + +# open logfile +open( my $logFH, ">", $logfile ) or die $!; +$logFH->autoflush(1); + +# start simulator as child process with communication pipes +my ($child_in, $child_out); +my $pid = eval{ open3( $child_in, $child_out, $child_out, @command ) }; +if ($@) { die $@; } + +# remember child PID +$::CHILD_PID = $pid; +#print "[child process ID is: $pid]\n"; + +# monitor output of child process +while( my $line = <$child_out> ) +{ + if ( $line =~ /^ABORT/ ) + { # some problem + print $logFH $line; + print $logFH "Problem running BioNetGen on ${scanmodel}."; + # also write message to STDOUT + die "Problem running BioNetGen on $scanmodel"; + } + else + { # write message to log + print $logFH $line; + if ($verbose){ + #print $line; # to STDOUT + } + } +} + +# make sure child process has completed +waitpid($pid,0); + +# clear child pid +$::CHILD_PID = undef; + + +$n_pts -= $offset; +# Process output +my $outfile = "${prefix}.scan"; +open(OUT,">", $outfile) or die "Couldn't open $outfile for output ($!)"; +{ + foreach my $run (1..$n_pts) + { + my @val1; + for (my $k= 0; $k < $n_dims; $k++) + { + if ($samplingMethod eq "\"latin\"") { + push @val1, $vals[$run + $n_dims - 1][$k]; + } else { + push @val1, $vals[$run - 1][$k]; + } + } + #{ local $\ = "\n"; print "\t [ @val1 ]," } + # Get data from gdat file + my $gdat_file = File::Spec->catfile( $prefix, sprintf("${prefix}_%05d.gdat", $run) ); + print "Extracting data from $gdat_file\n"; + #print "$gdat_file\n"; + open(IN, "<", $gdat_file) or die "Couldn't open $gdat_file for input ($!)"; + if ($run==1) + { + my $head = ; + $head =~ s/^\s*\#//; + my @heads = split(' ',$head); + shift @heads; + for (my $i = 0; $i < $n_dims; $i++) { + printf OUT "# %+14s", $mandatory_args[3*$i + 1]; + } + foreach my $head (@heads) + { + printf OUT " %+16s", $head; + } + print OUT "\n"; + } + my @last; + while (my $line = ) { + my @dat = split(' ',$line); + @last = @dat; + #print("@dat\n"); + } + open(IN, "<", $gdat_file) or die "Couldn't open $gdat_file for input ($!)"; + my @max; + my $count = 0; + my @dat; + my @peakInt; + #foreach my $x (@val1) { + # $x = $log ? exp($x) : $x; + # print("$x"); + #} + #print("\n"); + while (my $line = ) { + my @dat = split(' ',$line); + #print("@dat \n"); + if ($count == 1) { + @max = @dat; + for $i (0 .. $#peakInt) { + $peakInt[$i] = 0; + } + } elsif ($count > 1) { + my $i = 0; + foreach my $point (@dat) { + if ($max[$i] < $point) { + $max[$i] = $point; + } + if ($dat[$i] > $last[$i]) { + $peakInt[$i] += $dat[$i] - $last[$i]; + } + $i++; + } + } + $count++; + } + @dat = @last; + if ($varMeasured eq "\"peakHeight\"") { + for my $i (0 .. $#dat) { + $dat[$i] = $max[$i] - $last[$i]; + } + } elsif ($varMeasured eq "\"peakRatio\"") { + for $i (0 .. $#dat) { + $dat[$i] = ($max[$i] + DBL_EPSILON*100)/($last[$i] + DBL_EPSILON*100); + } + } elsif ($varMeasured eq "\"peakIntegral\"") { + @dat = @peakInt; + } elsif ($varMeasured eq "\"peakIntRatio\"") { + for $i (0 .. $#dat) { + $dat[$i] = ($peakInt[$i] + DBL_EPSILON*100)/($last[$i] + DBL_EPSILON*100); + } + } elsif ($varMeasured eq "\"peakWidth\"") { + for my $i (0 .. $#dat) { + $dat[$i] = $peakInt[$i]/$max[$i]; + } + } + #print("@dat\n"); + #my @dat = split(' ',$last); + my $time = shift @dat; + foreach my $x (@val1) { + $x = $log ? exp($x) : $x; + printf OUT "%16.8e", $x; + } + foreach my $data ( @dat ) + { + printf OUT " %16.8e", $data; + } + print OUT "\n"; + close(IN); + } +} +close(OUT); +print "Final state data printed to $outfile\n"; +exit 0; + + + + +# display help +sub display_help +{ +# print <>>relaying TERM signal to child with PID: ", $::CHILD_PID, " <<<\n"; + kill $SIGNO{"TERM"}, $::CHILD_PID; + } + die "BioNetGen received TERM signal"; +}; +# INT signal handler: make sure any child processes are shutdown before termination +$SIG{'INT'} = sub +{ + if (defined $::CHILD_PID) + { # kill off child process + print "\n>>> relaying INT signal to child with PID: ", $::CHILD_PID, " <<<\n"; + kill $SIGNO{"INT"}, $::CHILD_PID; + } + die "scan_var received INT signal"; +}; + + + +# get perl binary +my $perlbin = $^X; + +# get BNG path +my $bngpath; +my $bngexec; +{ + # try to find path in environment variables + $bngpath = (exists $ENV{'BNGPATH'} ? $ENV{'BNGPATH'} : + (exists $ENV{'BioNetGenRoot'} ? $ENV{'BioNetGenRoot'} : undef) ); + unless (defined $bngpath) + { # use FindBin to locate BNG + my ($volume,$directories,$file) = File::Spec->splitpath( $FindBin::RealBin ); + my @dirs = File::Spec->splitdir( $directories ); + pop @dirs; # BNG executable script should be down one directory from here + $bngpath = File::Spec->catpath( $volume, File::Spec->catdir(@dirs), '' ); + } + # define executable + $bngexec = File::Spec->catfile( $bngpath, "BNG2.pl" ); +} + +# some default parameters +my $log = 0; +my $t_end = 20; +my $n_steps = 1; +my $steady_state = 0; +my $method = "\"ode\""; +my $pla_output = 0; +my $verbose = 0; + +my $prefix; +my @mandatory_args = (); +while ( @ARGV ) +{ + my $arg = shift @ARGV; + if ( $arg =~ s/^(-{1,2})// ) + { + if ( $arg eq 'log' ){ + $log = 1; + } + elsif($arg eq 'n_steps'){ +# unless (@ARGV) { die "Syntax error: $arg requires value"; } + $n_steps = shift @ARGV; + if ($n_steps =~ /^-{1,2}/ || $n_steps =~ /\.bngl$/) + { die "Syntax error: '$arg' requires value"; } + } + elsif($arg eq 'prefix'){ +# unless (@ARGV) { die "Syntax error: $arg requires value"; } + $prefix = shift @ARGV; + if ($prefix =~ /^-{1,2}/ || $prefix =~ /\.bngl$/) + { die "Syntax error: '$arg' requires value"; } + } + elsif($arg eq 'steady_state'){ + $steady_state = 1; + } + elsif($arg eq 't_end'){ +# unless (@ARGV) { exit_error("Syntax error: $arg requires value"); } + $t_end = shift @ARGV; + if ($t_end =~ /^-{1,2}/ || $t_end =~ /\.bngl$/) + { die "Syntax error: '$arg' requires value"; } + } + elsif($arg eq 'method'){ + $method = shift @ARGV; + if ($method =~ /^-{1,2}/ || $method =~ /\.bngl$/) + { die "Syntax error: '$arg' requires value"; } + if ($method eq 'pla'){ + my $pla_config = shift @ARGV; + if ($pla_config =~ /^-{1,2}/ || $pla_config =~ /\.bngl$/) + { die "Syntax error: PLA simulator requires a simulation configuration: --method pla CONFIG. " . + "Please try again."; } + $method = "\"$method\",pla_config=>\"$pla_config\""; + } + else{ + $method = "\"$method\""; + } + } + elsif($arg eq 'pla_output'){ + $pla_output = 1; + } + elsif($arg eq 'verbose'){ + $verbose = 1; + } + elsif($arg eq 'help'){ + display_help(); + exit 0; + } + else{ + die "Syntax error: unrecognized command line option $arg"; + } + } + else + { # assume this is a mandatory argument + push @mandatory_args, $arg; + } +} + +#print "args: ", join(',', @mandatory_args), "\n"; +unless (@mandatory_args==5) +{ # complain about too few arguments + die "Syntax error: 5 required arguments (Try scan_var.pl --help)"; +} + +# get mandatory arguments +my ($file, $var, $var_min, $var_max, $n_pts) = @mandatory_args; + + +# Automatic assignment of prefix if unset +unless ($prefix) +{ + # separate directories from filename (if any) + my ($volume,$directories,$file) = File::Spec->splitpath( $file ); + unless ( $file =~ /\.bngl$/ ) + { die "Cannot extract prefix from filename $file"; } + # trim bngl extension to define prefix + ($prefix = $file) =~ s/\.bngl$//; +} +# add variable name to prefix +$prefix.="_${var}"; + + +if ($log) +{ # convert min and max into log values + $var_min = log($var_min); + $var_max = log($var_max); +} + +# calculate parameter step +my $delta; +if ($var_max==$var_min){ + $delta = 0; +} +else{ + $delta = ($var_max-$var_min)/($n_pts-1); +} + +# Read file +open(IN, $file) or die "Couldn't open file $file: $?\n"; +my $script = ""; +while ( my $line = ) +{ + $script .= $line; + # Skip actions + last if ($line =~ /^\s*end\s+model/); +} +close(IN); + +# Require 'end model' directive +if (!($script =~ /\n\s*end\s+model/)){ + die "ERROR: scan_var requires model to be enclosed in 'begin model' / 'end model' block."; +} + +# prepare working directory +if (-d $prefix) +{ # delete output directory + print "WARNING: overwriting existing work directory $prefix.\n"; + my $err; + remove_tree( $prefix, {'safe'=>1, 'keep_root'=>1, 'error'=> \$err} ); + if (@$err) + { die "Unable to delete files in work directory $prefix"; } +} +else +{ # make directory for output files + mkdir $prefix; +} + +# Create model file with scan actions +my $scanmodel = File::Spec->catfile( ${prefix}, "${prefix}.bngl" ); +my $logfile = File::Spec->catfile( ${prefix}, "${prefix}.log" ); + +open(BNGL,">", $scanmodel) or die "Couldn't open $scanmodel for output"; +print BNGL $script; +print BNGL "\n"; +print BNGL "generate_network({overwrite=>1})\n"; + +{ + my $val = $var_min; + foreach my $run (1..$n_pts) + { + my $srun = sprintf "%05d", $run; + if ($run > 1){ + print BNGL "resetConcentrations()\n"; + } + my $x= $val; + if ($log){ $x = exp($val);} + printf BNGL "setParameter(\"$var\",%.12g)\n", $x; + + my $opt = "method=>$method"; + if ($pla_output){ + $opt .= ",pla_output=>1"; + } + $opt .= ",suffix=>\"$srun\",t_end=>$t_end,n_steps=>$n_steps"; + if ($steady_state){ + $opt .= ",steady_state=>1"; + } + if ($verbose){ + $opt .= ",verbose=>1"; + } + printf BNGL "simulate({$opt})\n"; #"simulate_ode({$opt})\n"; + + $val += $delta; + } +} +close(BNGL); + + + + + +# Run BioNetGen on ScanModel file +print "Running BioNetGen on $scanmodel\n"; +my @command = ($perlbin, $bngexec, "--outdir", $prefix, $scanmodel); + +# open logfile +open( my $logFH, ">", $logfile ) or die $!; +$logFH->autoflush(1); + +# start simulator as child process with communication pipes +my ($child_in, $child_out); +my $pid = eval{ open3( $child_in, $child_out, $child_out, @command ) }; +if ($@) { die $@; } + +# remember child PID +$::CHILD_PID = $pid; +print "[child process ID is: $pid]\n"; + +# monitor output of child process +while( my $line = <$child_out> ) +{ + if ( $line =~ /^ABORT/ ) + { # some problem + print $logFH $line; + print $logFH "Problem running BioNetGen on ${scanmodel}."; + # also write message to STDOUT + print $line; + die "Problem running BioNetGen on $scanmodel"; + } + else + { # write message to log + print $logFH $line; + if ($verbose){ + print $line; # to STDOUT + } + } +} + +# make sure child process has completed +waitpid($pid,0); + +# clear child pid +$::CHILD_PID = undef; + + + + +# Process output +my $outfile = "${prefix}.scan"; +open(OUT,">", $outfile) or die "Couldn't open $outfile for output ($!)"; +{ + my $val = $var_min; + foreach my $run (1..$n_pts) + { + # Get data from gdat file + my $gdat_file = File::Spec->catfile( $prefix, sprintf("${prefix}_%05d.gdat", $run) ); + print "Extracting data from $gdat_file\n"; + open(IN, "<", $gdat_file) or die "Couldn't open $gdat_file for input ($!)"; + if ($run==1) + { + my $head = ; + $head =~ s/^\s*\#//; + my @heads = split(' ',$head); + shift @heads; + printf OUT "# %+14s", $var; + foreach my $head (@heads) + { + printf OUT " %+16s", $head; + } + print OUT "\n"; + } + my $last; + while (my $line = ) { $last = $line }; + my @dat = split(' ',$last); + my $time = shift @dat; + my $x = $log ? exp($val) : $val; +# printf OUT "%16.8e %s\n", $x, join(' ',@dat); + printf OUT "%16.8e", $x; + foreach my $data ( @dat ) + { + printf OUT " %16.8e", $data; + } + print OUT "\n"; + close(IN); + $val += $delta; + } +} +close(OUT); +print "Final state data printed to $outfile\n"; +exit 0; + + + + +# display help +sub display_help +{ +# print <initialize( $lists ); + + + +print STDERR "iterate over elements..\n"; +my $elem = []; +while ( $cartprod->getNext($elem) ) +{ + print STDERR "elem: ", join( ',', @$elem ), "\n"; +} + +print STDERR "add more numbers..\n"; +if ( $cartprod->update(0,[5,6]) ) +{ + print STDERR "valid? ", $cartprod->validate(), "\n"; + print STDERR "successful update! continue iteration..\n"; + while ( $cartprod->getNext($elem) ) + { + print STDERR "elem: ", join( ',', @$elem ), "\n"; + } +} + + +print STDERR "add more marshes..\n"; +if ( $cartprod->update(2,['Lisa','Poochie']) ) +{ + print STDERR "valid? ", $cartprod->validate(), "\n"; + print STDERR "successful update! continue iteration..\n"; + while ( $cartprod->getNext($elem) ) + { + print STDERR "elem: ", join( ',', @$elem ), "\n"; + } +} + + diff --git a/libvcell/vcell_install/bionetgen/Perl2/verify.pl b/libvcell/vcell_install/bionetgen/Perl2/verify.pl new file mode 100755 index 0000000..8291b61 --- /dev/null +++ b/libvcell/vcell_install/bionetgen/Perl2/verify.pl @@ -0,0 +1,178 @@ +#!/usr/bin/perl + +# Program verify.pl compares two time course files. For the +# purpose of computing the norm error, the second file is the reference. +# +# Usage verify.pl datafile1 datafile2 +# +# Outputs: +# Either PASSED or FAILED (or possibly a general error message) +# depending upon magnitude of norm error. The configuration variable +# $BUILD_ERR_THRESH can be set in this file (or bngrc or the local +# .bngrc file). +# +# Thanks to Robert Seletsky, the original author of this script, and Stan +# Steinberg, who suggested using the norm error +# err= |m2-m1|/|m2| +# = sqrt( sum_{ij}((m2_{ij} - m1_{ij})**2)/ sum_{ij}(m2_{ij})**2), +# where m1 and m2 are the arrays containing the time course data at i time +# points for j variables. + +# UPDATE: 16 dec 2010 by Justin Hogg +# Improved messages. +# Added strict and warnings pragmas. + +# Recall that $0 is the name of the the executing perl script! + +use strict; +use warnings; + + +my $BUILD_ERR_THRESH = 1e-7; +my $COLUMN_OFFSET = 0; + +my $INDENT = ''; + +# Read command line arguments +while ( $ARGV[0] =~ /^-/) +{ + my $arg = shift @ARGV; + if ( $arg =~ /^-offset$/) + { + $COLUMN_OFFSET = shift; + } + else + { + die $INDENT . "$0 ERROR: unrecognized command line option $arg"; + } +} + +# check that we have two more arguments (filenames!) +if ( @ARGV != 2 ) +{ + die $INDENT . "ERROR: usage = $0 filename filename2\n"; +} + +my $rfilename = shift @ARGV; +my $rfilename2 = shift @ARGV; + +print $INDENT . "$0 is comparing $rfilename and $rfilename2\n"; + + +# read first data file +open (RFILE, $rfilename) or die $INDENT . "$0 ERROR: can't open $rfilename: $!\n"; +my @data = (); +my @times = (); +while ( my $line = ) +{ + $line =~ s/\#.*$//; # remove comments + $line =~ s/^\s+//; # remove leading whitespace + $line =~ s/\s+$//; # remove trailing whitespace + + # is there any line left? + next unless ( $line =~ /\S+/ ); + # split at whitespace + my @elem = split /\s+/, $line; + # first element is time + push @times, shift @elem; + # remaining elements are data + push @data, [ @elem ]; +} +close RFILE; + + +# read second data file +open (RFILE, $rfilename2) or die $INDENT . "$0 ERROR: can't open $rfilename2: $!!!\n"; +my @data2=(); +my @times2=(); +while ( my $line = ) +{ + $line =~ s/\#.*$//; # remove comments + $line =~ s/^\s+//; # remove leading whitespace + $line =~ s/\s+$//; # remove trailing whitespace + + # is there any line left? + next unless ( $line =~ /\S+/ ); + # split at whitespace + my @elem = split /\s+/, $line; + # first element is time + push @times2, shift @elem; + # remaining elements are data + push @data2, [ @elem ]; +} +close RFILE; + + + +# Check that the time points in the two files are the same +unless ( @times == @times2 ) +{ + print $INDENT . "FAILED!! data files have different timepoints.\n"; + printf $INDENT . " %d time point(s) in $rfilename.\n", scalar @times; + printf $INDENT . " %d time point(s) in $rfilename2.\n", scalar @times2; + exit 1; +} + +# Verify time points are the same +for ( my $i=0; $i < @times; ++$i ) +{ + unless ( $times[$i] == $times2[$i] ) + { + print $INDENT . "FAILED!! data files have different timepoints.\n"; + exit 1; + } +} + +# Verify that the number of data points are compatible +for ( my $i=0; $i < @times; ++$i ) +{ + unless ( @{$data[$i]} == @{$data2[$i]} + $COLUMN_OFFSET ) + { + print $INDENT . "FAILED!! datafiles have different number of data columns!\n"; + exit 1; + } +} + + +# Compute normerr +my $sresult = normerr( \@data, \@data2); + + +# Check if normerr is in bounds +if ( $sresult > $BUILD_ERR_THRESH ) +{ + print $INDENT . sprintf "FAILED!! norm error (%E) > threshold error (%E).\n", $sresult, $BUILD_ERR_THRESH; + exit 1; +} +else +{ + print $INDENT . sprintf "PASSED!! norm error (%E) <= threshold error (%E).\n", $sresult, $BUILD_ERR_THRESH; + exit 0; +} + + + + + +# Compute norm error between two data sets stored in two rectangular arrays m1 +# and m2 of the same dimension (not checked) +sub normerr +{ + my $data1 = shift; + my $data2 = shift; + + my $delta2 = 0; + my $ref2 = 0; + + for ( my $i=0; $i < @$data1; ++$i ) + { + for ( my $j=0; $j < @{$data1->[$i]}; ++$j ) + { + # offset columns in data2 (why??? -justin) + my $j2 = $j + $COLUMN_OFFSET; + $delta2 += ( $data2->[$i][$j2] - $data1->[$i][$j] )**2; + $ref2 += ( $data2->[$i][$j2] )**2; + } + } + return sqrt( $delta2/$ref2 ); +} diff --git a/libvcell/vcell_install/bionetgen/README.md b/libvcell/vcell_install/bionetgen/README.md new file mode 100644 index 0000000..3a4d4e9 --- /dev/null +++ b/libvcell/vcell_install/bionetgen/README.md @@ -0,0 +1,19 @@ +# BioNetGen 2.9.3 (bundled) + +The Perl part of [BioNetGen](https://github.com/RuleWorld/bionetgen) 2.9.3, MIT-licensed (`LICENSE`, `CREDITS.txt`): +`BNG2.pl` and its `Perl2/` modules, copied unchanged from the official release +`BioNetGen-2.9.3-linux.tar.gz` (sha256 `b85743d422aa3fd112aceb3725dd1b1f2ff1ad829d20d71682680426582bcb5d`; +identical in the mac release, and in the win release apart from line endings). + +VCell runs it to expand a rule-based application's reaction rules into a reaction network when it generates the +math (`perl BNG2.pl`), looking for it at `/bionetgen/BNG2.pl`; libvcell points `vcell.installDir` +at this package's `vcell_install/`. Only network generation is used, so BioNetGen's compiled simulators (`bin/`) are +not included. It needs `perl` on the `PATH` (macOS and most Linux have it; on Windows, e.g. Strawberry Perl). Without +it libvcell falls back to the math stored in the document and says so. + +**Checked against VCell's own BioNetGen (2.3.0, `vcell_submodule/bionetgen`)** on the 109 rule-based models with ODE +simulations in a 2,730-model VCell corpus (2026-10-23): 103 give byte-identical solver input with either version, and +the other 6 fail identically with both (unit errors and invalid sizes in the models, two BioNetGen timeouts). Recheck +like this before updating to a newer release. + +To update: copy `BNG2.pl`, `Perl2/`, `VERSION`, `LICENSE` and `CREDITS.txt` from a newer release and update this file. diff --git a/libvcell/vcell_install/bionetgen/VERSION b/libvcell/vcell_install/bionetgen/VERSION new file mode 100644 index 0000000..eafef0d --- /dev/null +++ b/libvcell/vcell_install/bionetgen/VERSION @@ -0,0 +1 @@ +2.9.3 \ No newline at end of file diff --git a/pyproject.toml b/pyproject.toml index 398f055..674b5a5 100644 --- a/pyproject.toml +++ b/pyproject.toml @@ -4,7 +4,7 @@ build-backend = "poetry.core.masonry.api" [tool.poetry] name = "libvcell" -version = "0.0.21" +version = "0.0.22" description = "This is a python package which wraps a subset of VCell Java code as a native python package." authors = ["Jim Schaff ", "Ezequiel Valencia "] repository = "https://github.com/virtualcell/libvcell" @@ -15,7 +15,9 @@ packages = [ ] include = [ {path="libvcell/lib/libvcell*", format="wheel"}, - {path="libvcell/py.typed"} + {path="libvcell/py.typed"}, + # BioNetGen (BNG2.pl and its Perl modules), which VCell runs to generate rule-based reaction networks + {path="libvcell/vcell_install/**/*"} ] [tool.poetry.dependencies] diff --git a/scripts/local_build_native.sh b/scripts/local_build_native.sh index 0d90cc7..f090191 100755 --- a/scripts/local_build_native.sh +++ b/scripts/local_build_native.sh @@ -28,8 +28,9 @@ cd "$ROOT_DIR"/vcell-native || ( echo "'vcell-native' directory not found" && ex # build vcell-native as java mvn clean install -# run with native-image-agent to record configuration for native-image -java -agentlib:native-image-agent=config-output-dir=target/recording \ +# run with native-image-agent to record configuration for native-image (with the bundled BioNetGen, so the +# recording covers generating a rule-based reaction network) +LIBVCELL_VCELL_INSTALL_DIR="$ROOT_DIR/libvcell/vcell_install" java -agentlib:native-image-agent=config-output-dir=target/recording \ -jar target/vcell-native-1.0-SNAPSHOT.jar \ "$ROOT_DIR/vcell-native/src/test/resources/TinySpatialProject_Application0.xml" \ "$ROOT_DIR/vcell-native/src/test/resources/TinySpatialProject_Application0.vcml" \ diff --git a/tests/test_libvcell.py b/tests/test_libvcell.py index cdf273b..ffb7607 100644 --- a/tests/test_libvcell.py +++ b/tests/test_libvcell.py @@ -1,3 +1,4 @@ +import shutil import tempfile from pathlib import Path @@ -304,12 +305,24 @@ def test_sbml_to_ode_input_refuses_a_non_positive_duration(temp_output_dir: Path @_skip_no_ode -def test_vcml_to_ode_input_uses_the_stored_math_of_a_rule_based_application( +@pytest.mark.skipif(shutil.which("perl") is None, reason="BioNetGen runs with perl") +def test_vcml_to_ode_input_regenerates_a_rule_based_application_with_the_bundled_bionetgen( temp_output_dir: Path, rule_based_vcml_file_path: Path ) -> None: - """Its network needs BioNetGen to regenerate, which libvcell does not include, so the stored math is used.""" + success, msg = vcml_to_ode_input(rule_based_vcml_file_path.read_text(), "Simulation0", temp_output_dir) + assert success is True, msg + assert ";" not in msg # regenerated: just the input file's name + _solves(temp_output_dir / msg) + + +@_skip_no_ode +def test_vcml_to_ode_input_falls_back_to_the_stored_math_without_bionetgen( + temp_output_dir: Path, rule_based_vcml_file_path: Path, monkeypatch: pytest.MonkeyPatch +) -> None: + """Without BioNetGen (here: a directory with none), the stored math is used and the message says why.""" + monkeypatch.setenv("LIBVCELL_VCELL_INSTALL_DIR", str(temp_output_dir)) success, msg = vcml_to_ode_input(rule_based_vcml_file_path.read_text(), "Simulation0", temp_output_dir) assert success is True, msg name, _, note = msg.partition("; ") - assert note.startswith("stored math (rule-based application") + assert note.startswith("stored math (rule-based application: BioNetGen could not regenerate"), note _solves(temp_output_dir / name) diff --git a/vcell-native/src/main/java/org/vcell/libvcell/BioNetGenSupport.java b/vcell-native/src/main/java/org/vcell/libvcell/BioNetGenSupport.java new file mode 100644 index 0000000..a9d7b40 --- /dev/null +++ b/vcell-native/src/main/java/org/vcell/libvcell/BioNetGenSupport.java @@ -0,0 +1,41 @@ +package org.vcell.libvcell; + +import java.io.File; + +/** + * Points VCell at the BioNetGen libvcell bundles. VCell runs {@code perl /bionetgen/BNG2.pl} to + * expand a rule-based application's reaction rules into a reaction network when it generates the math; the Python + * package ships BioNetGen in {@code libvcell/vcell_install/bionetgen/} and names that directory in the + * {@value #INSTALL_DIR_ENV} environment variable (each native call runs in its own isolate, so the setting is made + * at the start of every call rather than once). + */ +public final class BioNetGenSupport { + + /** The environment variable naming a directory that holds {@code bionetgen/BNG2.pl}. */ + public static final String INSTALL_DIR_ENV = "LIBVCELL_VCELL_INSTALL_DIR"; + private static final String INSTALL_DIR_PROPERTY = "vcell.installDir"; + + private BioNetGenSupport() { + } + + /** Set {@code vcell.installDir} from {@value #INSTALL_DIR_ENV}, unless it is already set or names no BioNetGen. */ + public static void configure() { + if (System.getProperty(INSTALL_DIR_PROPERTY) != null) { + return; + } + String dir = System.getenv(INSTALL_DIR_ENV); + if (dir != null && !dir.isEmpty() && new File(new File(dir, "bionetgen"), "BNG2.pl").isFile()) { + System.setProperty(INSTALL_DIR_PROPERTY, dir); + } + } + + /** The innermost message of a failure (e.g. "failed to find installed perl ..."), for reporting why. */ + static String rootMessage(Throwable t) { + Throwable root = t; + while (root.getCause() != null && root.getCause() != root) { + root = root.getCause(); + } + String message = root.getMessage(); + return (message == null || message.isBlank()) ? root.getClass().getSimpleName() : message.strip(); + } +} diff --git a/vcell-native/src/main/java/org/vcell/libvcell/Entrypoints.java b/vcell-native/src/main/java/org/vcell/libvcell/Entrypoints.java index f5e5aaa..f8b2b14 100644 --- a/vcell-native/src/main/java/org/vcell/libvcell/Entrypoints.java +++ b/vcell-native/src/main/java/org/vcell/libvcell/Entrypoints.java @@ -97,9 +97,6 @@ public static void freeString( } // serialized in JSON and returned as a String (CCharPointer) - /** Appended to vcmlToOdeInput's message when the document's stored math was used (a rule-based application). */ - static final String STORED_MATH_NOTE = "stored math (rule-based application: BioNetGen, which would regenerate its reaction network, is not available in libvcell)"; - public record ReturnValue(boolean success, String message) { public String toJson() { String escaped_message = JSONValue.escape(message); @@ -241,7 +238,8 @@ public static CCharPointer entrypoint_vcmlToMovingBoundaryInput( simulation_name: name of the simulation to convert (CVODE, IDA or Combined IDA/CVODE solver) output_dir_path: path to the output directory Returns a JSON string with success status and, on success, a message: the input file's name, - then "; stored math (...)" when the document's stored math was used (a rule-based application)""" + then "; stored math (rule-based application: )" when the document's stored math was used + because BioNetGen could not regenerate a rule-based application's network""" ) public static CCharPointer entrypoint_vcmlToOdeInput( IsolateThread ignoredThread, @@ -257,7 +255,7 @@ public static CCharPointer entrypoint_vcmlToOdeInput( String name = odeInput.inputFile().getName(); // the input file's name, then (after "; ") a note when the stored math was used; file names have no ";" returnValue = new ReturnValue(true, odeInput.usedStoredMath() - ? name + "; " + STORED_MATH_NOTE + ? name + "; stored math (rule-based application: " + odeInput.storedMathReason() + ")" : name); }catch (Throwable t) { logger.error("Error processing ODE model", t); diff --git a/vcell-native/src/main/java/org/vcell/libvcell/ModelUtils.java b/vcell-native/src/main/java/org/vcell/libvcell/ModelUtils.java index 42ddcc9..a86b642 100644 --- a/vcell-native/src/main/java/org/vcell/libvcell/ModelUtils.java +++ b/vcell-native/src/main/java/org/vcell/libvcell/ModelUtils.java @@ -36,6 +36,7 @@ public class ModelUtils { public static void sbml_to_vcml(String sbml_content, Path vcmlPath) throws VCLoggerException, XmlParseException, IOException, MappingException { + BioNetGenSupport.configure(); GeometrySpec.avoidAWTImageCreation = true; XmlHelper.cloneUsingXML = true; @@ -79,6 +80,7 @@ record LoggerMessage(VCLogger.Priority priority, VCLogger.ErrorType errorType, S public static void vcml_to_sbml(String vcml_content, String applicationName, Path sbmlPath, boolean roundTripValidation) throws XmlParseException, IOException, XMLStreamException, SbmlException, MappingException, ImageException, GeometryException, ExpressionException { + BioNetGenSupport.configure(); GeometrySpec.avoidAWTImageCreation = true; XmlHelper.cloneUsingXML = true; VCMongoMessage.enabled = false; @@ -119,6 +121,7 @@ public static void vcml_to_sbml(String vcml_content, String applicationName, Pat } public static void vcml_to_vcml(String vcml_content, Path vcmlPath) throws XmlParseException, IOException, MappingException { + BioNetGenSupport.configure(); GeometrySpec.avoidAWTImageCreation = true; XmlHelper.cloneUsingXML = true; VCMongoMessage.enabled = false; @@ -136,6 +139,7 @@ public static void vcml_to_vcml(String vcml_content, Path vcmlPath) throws XmlPa * included, so the math is unchanged. */ public static void vcml_convert_units(String vcml_content, String unit_system, Path vcmlPath) throws Exception { + BioNetGenSupport.configure(); GeometrySpec.avoidAWTImageCreation = true; XmlHelper.cloneUsingXML = true; VCMongoMessage.enabled = false; diff --git a/vcell-native/src/main/java/org/vcell/libvcell/SolverUtils.java b/vcell-native/src/main/java/org/vcell/libvcell/SolverUtils.java index 740205c..df643fa 100644 --- a/vcell-native/src/main/java/org/vcell/libvcell/SolverUtils.java +++ b/vcell-native/src/main/java/org/vcell/libvcell/SolverUtils.java @@ -42,6 +42,7 @@ public class SolverUtils { private static final Logger logger = LogManager.getLogger(Entrypoints.class); public static void vcmlToFiniteVolumeInput(String vcml_content, String simulation_name, File parentDir, File outputDir) throws XmlParseException, MappingException, SolverException, ExpressionException, MathException { + BioNetGenSupport.configure(); GeometrySpec.avoidAWTImageCreation = true; XmlHelper.cloneUsingXML = true; VCMongoMessage.enabled = false; @@ -69,6 +70,7 @@ public static void vcmlToFiniteVolumeInput(String vcml_content, String simulatio } public static void vcmlToMovingBoundaryInput(String vcml_content, String simulation_name, File outputDir) throws XmlParseException, MappingException, SolverException, ExpressionException, MathException { + BioNetGenSupport.configure(); GeometrySpec.avoidAWTImageCreation = true; XmlHelper.cloneUsingXML = true; VCMongoMessage.enabled = false; @@ -177,12 +179,18 @@ private static FieldDataIdentifierSpec[] getFieldDataIdentifierSpecs(Simulation * @return the input file written ({@code .cvodeInput} or {@code .idaInput}) */ /** - * The ODE solver input written for a simulation: the input file, and whether the document's stored math was used - * instead of regenerating it (a rule-based application, see {@link #refreshSimulationMath}). + * The ODE solver input written for a simulation: the input file, and why the document's stored math was used + * instead of regenerating it (a rule-based application BioNetGen could not regenerate, see + * {@link #refreshSimulationMath}), or null when it was regenerated. */ - public record OdeInput(File inputFile, boolean usedStoredMath) {} + public record OdeInput(File inputFile, String storedMathReason) { + public boolean usedStoredMath() { + return storedMathReason != null; + } + } public static OdeInput vcmlToOdeInput(String vcml_content, String simulation_name, File outputDir) throws XmlParseException, MappingException, SolverException, ExpressionException, MathException { + BioNetGenSupport.configure(); GeometrySpec.avoidAWTImageCreation = true; XmlHelper.cloneUsingXML = true; VCMongoMessage.enabled = false; @@ -195,40 +203,42 @@ public static OdeInput vcmlToOdeInput(String vcml_content, String simulation_nam if (sim == null) { throw new IllegalArgumentException("Simulation not found: " + simulation_name); } - boolean usedStoredMath = refreshSimulationMath(bioModel, sim); - return new OdeInput(writeOdeInput(sim, simulation_name, outputDir), usedStoredMath); + String storedMathReason = refreshSimulationMath(bioModel, sim); + return new OdeInput(writeOdeInput(sim, simulation_name, outputDir), storedMathReason); } /** * Regenerate the math of the simulation's own application (not every application in the document, so another * application VCell cannot generate math for does not get in the way). * - *

A rule-based application (reaction rules, expanded into a reaction network by BioNetGen) is the - * exception: network generation runs BioNetGen's BNG2.pl from a VCell installation, which libvcell does not - * have. For it the math stored in the document is used, which is the network VCell generated when the model was - * saved, and what the VCell server runs for a saved simulation. A document without stored math for it cannot be - * converted. + *

A rule-based application (reaction rules) has its reaction network generated by BioNetGen, which libvcell + * bundles ({@link BioNetGenSupport}) and runs with {@code perl}. If that fails (no {@code perl}, or BioNetGen + * fails), the math stored in the document is used instead: the network VCell generated when the model was saved, + * which is what the VCell server runs for a saved simulation. * - * @return whether the stored math was used + * @return why the stored math was used, or null when the math was regenerated */ - static boolean refreshSimulationMath(BioModel bioModel, Simulation sim) throws MappingException { + static String refreshSimulationMath(BioModel bioModel, Simulation sim) throws MappingException { if (!(sim.getSimulationOwner() instanceof SimulationContext simContext)) { bioModel.updateAll(false); // not an application's simulation (a MathModel's): as before - return false; + return null; } bioModel.refreshDependencies(); - if (simContext.createNewTransformer() instanceof NetworkTransformer) { + if (!(simContext.createNewTransformer() instanceof NetworkTransformer)) { + simContext.updateAll(false); + return null; + } + try { + simContext.updateAll(false); // BioNetGen generates the reaction network + return null; + } catch (MappingException e) { if (sim.getMathDescription() == null) { - throw new IllegalArgumentException("Simulation '" + sim.getName() + "' is in rule-based application '" - + simContext.getName() + "', whose reaction network needs BioNetGen to generate, which libvcell" - + " does not include; and the document stores no math for it to use instead"); + throw e; } - logger.warn("Application '" + simContext.getName() + "' is rule-based: using its stored math (BioNetGen," - + " which would regenerate its reaction network, is not available in libvcell)"); - return true; + String reason = "BioNetGen could not regenerate its reaction network: " + BioNetGenSupport.rootMessage(e); + logger.warn("Application '" + simContext.getName() + "' is rule-based and " + reason + "; using its stored math"); + return reason; } - simContext.updateAll(false); - return false; } /** @@ -239,6 +249,7 @@ static boolean refreshSimulationMath(BioModel bioModel, Simulation sim) throws M * @return the input file written ({@code .cvodeInput} or {@code .idaInput}) */ public static File sbmlToOdeInput(String sbml_content, double duration, double output_time_step, File outputDir) throws MappingException, PropertyVetoException, SolverException, ExpressionException, VCLoggerException, MathException { + BioNetGenSupport.configure(); GeometrySpec.avoidAWTImageCreation = true; XmlHelper.cloneUsingXML = true; VCMongoMessage.enabled = false; @@ -290,6 +301,7 @@ private static File writeOdeInput(Simulation sim, String simulation_label, File } public static void sbmlToFiniteVolumeInput(String sbml_content, File outputDir) throws MappingException, PropertyVetoException, SolverException, ExpressionException, VCLoggerException { + BioNetGenSupport.configure(); GeometrySpec.avoidAWTImageCreation = true; XmlHelper.cloneUsingXML = true; VCMongoMessage.enabled = false; diff --git a/vcell-native/src/test/java/org/vcell/libvcell/SolverEntrypointsTest.java b/vcell-native/src/test/java/org/vcell/libvcell/SolverEntrypointsTest.java index 16503a2..1457a4d 100644 --- a/vcell-native/src/test/java/org/vcell/libvcell/SolverEntrypointsTest.java +++ b/vcell-native/src/test/java/org/vcell/libvcell/SolverEntrypointsTest.java @@ -303,10 +303,28 @@ public void testVcmlToOdeInput_rule_based_uses_the_stored_math() throws Exceptio File output_dir = Files.createTempDirectory("vcmlToOdeInput_" + UUID.randomUUID()).toFile(); SolverUtils.OdeInput odeInput = vcmlToOdeInput(vcmlContent, "Simulation0", output_dir); File input = odeInput.inputFile(); - assertTrue(odeInput.usedStoredMath()); + assertTrue(odeInput.usedStoredMath()); // no vcell.installDir here, so BioNetGen cannot run + assertTrue(odeInput.storedMathReason().startsWith("BioNetGen could not regenerate"), odeInput.storedMathReason()); String first = firstLine(input); assertTrue(first.equals("SOLVER CVODE") || first.equals("SOLVER IDA"), first); assertTrue(Files.readString(input.toPath()).contains("NUM_EQUATIONS")); } + @Test + public void testVcmlToOdeInput_rule_based_regenerated_with_the_bundled_bionetgen() throws Exception { + // the BioNetGen the Python package bundles (libvcell/vcell_install/bionetgen, run with perl) + File installDir = new File("../libvcell/vcell_install").getCanonicalFile(); + assertTrue(new File(installDir, "bionetgen/BNG2.pl").isFile(), installDir.toString()); + String vcmlContent = getFileContentsAsString("/public_biomodel_100992568_rule_based.vcml"); + File output_dir = Files.createTempDirectory("vcmlToOdeInput_" + UUID.randomUUID()).toFile(); + System.setProperty("vcell.installDir", installDir.getPath()); + try { + SolverUtils.OdeInput odeInput = vcmlToOdeInput(vcmlContent, "Simulation0", output_dir); + assertFalse(odeInput.usedStoredMath(), odeInput.storedMathReason()); + assertTrue(Files.readString(odeInput.inputFile().toPath()).contains("NUM_EQUATIONS")); + } finally { + System.clearProperty("vcell.installDir"); + } + } + } From 089c7af3fefedbe242ca911c73bb848b59d590c6 Mon Sep 17 00:00:00 2001 From: Jim Schaff Date: Fri, 23 Oct 2026 22:28:29 -0400 Subject: [PATCH 2/3] Windows: pack BioNetGen 2.9.3 into a standalone BNG2.exe VCell's Windows code launches bionetgen/win64Standalone/BNG2.exe, never perl BNG2.pl, so the bundled BNG2.pl was unused on Windows (CI: "CreateProcess error=2", the regeneration test failed). The old 2.3.0 BNG2.exe in VCell's repository is GPLv3; this builds a new one from the bundled MIT 2.9.3. - scripts/pack_bionetgen.sh packs BNG2.pl and Perl2/ with PAR::Packer (-I Perl2 and every module named, since BNG2.pl looks for Perl2/ beside itself) into a standalone executable with its own Perl, then smoke-tests it by generating a network with nothing from outside it. Prototyped on macOS: the packed binary generates the same network as perl BNG2.pl (egfr_net, 4,177 lines). - The Windows jobs of main.yml and on-release-main.yml install PAR::Packer and run it before the build, cached on a hash of the BioNetGen files and the script. - The exe is git-ignored and included in the wheel; build.py warns on Windows when it is missing (rule-based models then use their stored math). - The Python regeneration test needs the exe on Windows and perl elsewhere. Co-Authored-By: Claude Opus 5.5 --- .github/workflows/main.yml | 15 ++++++ .github/workflows/on-release-main.yml | 15 ++++++ .gitignore | 3 ++ CLAUDE.md | 5 +- build.py | 9 ++++ libvcell/vcell_install/bionetgen/README.md | 6 ++- pyproject.toml | 4 +- scripts/pack_bionetgen.sh | 62 ++++++++++++++++++++++ tests/test_libvcell.py | 14 ++++- 9 files changed, 128 insertions(+), 5 deletions(-) create mode 100755 scripts/pack_bionetgen.sh diff --git a/.github/workflows/main.yml b/.github/workflows/main.yml index ee7a2c9..d577b49 100644 --- a/.github/workflows/main.yml +++ b/.github/workflows/main.yml @@ -75,6 +75,21 @@ jobs: native-image-job-reports: "true" cache: "maven" + - name: Cache the packed BioNetGen (Windows) + if: runner.os == 'Windows' + id: bionetgen-exe + uses: actions/cache@v4 + with: + path: libvcell/vcell_install/bionetgen/win64Standalone/BNG2.exe + key: bionetgen-exe-${{ hashFiles('libvcell/vcell_install/bionetgen/**', 'scripts/pack_bionetgen.sh') }} + + - name: Pack BioNetGen for Windows (PAR::Packer) + # VCell runs bionetgen/win64Standalone/BNG2.exe on Windows, not perl BNG2.pl (scripts/pack_bionetgen.sh) + if: runner.os == 'Windows' && steps.bionetgen-exe.outputs.cache-hit != 'true' + run: | + cpanm --notest PAR::Packer + scripts/pack_bionetgen.sh + - name: Install python dependencies run: poetry install --no-interaction diff --git a/.github/workflows/on-release-main.yml b/.github/workflows/on-release-main.yml index f1e572e..7a0b127 100644 --- a/.github/workflows/on-release-main.yml +++ b/.github/workflows/on-release-main.yml @@ -94,6 +94,21 @@ jobs: CIBW_MANYLINUX_AARCH64_IMAGE: "${{ env.MANYLINUX_IMAGE_TARGET }}" # CIBW_BUILD_VERBOSITY_LINUX: 2 + - name: Cache the packed BioNetGen (Windows) + if: runner.os == 'Windows' + id: bionetgen-exe + uses: actions/cache@v4 + with: + path: libvcell/vcell_install/bionetgen/win64Standalone/BNG2.exe + key: bionetgen-exe-${{ hashFiles('libvcell/vcell_install/bionetgen/**', 'scripts/pack_bionetgen.sh') }} + + - name: Pack BioNetGen for Windows (PAR::Packer) + # VCell runs bionetgen/win64Standalone/BNG2.exe on Windows, not perl BNG2.pl (scripts/pack_bionetgen.sh) + if: runner.os == 'Windows' && steps.bionetgen-exe.outputs.cache-hit != 'true' + run: | + cpanm --notest PAR::Packer + scripts/pack_bionetgen.sh + - name: Run cibuildwheel if: ${{ !startsWith(matrix.os, 'ubuntu') }} run: | diff --git a/.gitignore b/.gitignore index 2bccf3b..26bdf40 100644 --- a/.gitignore +++ b/.gitignore @@ -173,3 +173,6 @@ cython_debug/ #.idea/ .idea/ + +# BioNetGen packed for Windows by scripts/pack_bionetgen.sh (a build product, shipped in the Windows wheel) +libvcell/vcell_install/bionetgen/win64Standalone/ diff --git a/CLAUDE.md b/CLAUDE.md index 182e21b..c572d73 100644 --- a/CLAUDE.md +++ b/CLAUDE.md @@ -91,7 +91,10 @@ when it generates the math. The Python package sets `LIBVCELL_VCELL_INSTALL_DIR` (`_internal/native_utils.py`), and `BioNetGenSupport.configure()`, called at the start of every model-building method, turns it into `vcell.installDir` (each call runs in a fresh isolate). Without `perl` or BioNetGen, `vcml_to_ode_input` falls back to the document's stored math and says why in its message. The recorder run in -`build.py` sets the variable too, so native-image records the BioNetGen path. +`build.py` sets the variable too, so native-image records the BioNetGen path. On Windows VCell runs +`bionetgen/win64Standalone/BNG2.exe` instead of `perl BNG2.pl`: `scripts/pack_bionetgen.sh` packs it from the same +files with PAR::Packer (and smoke-tests it); the Windows jobs of both workflows run it before the build (cached on a +hash of the BioNetGen files and the script), and the exe is git-ignored but included in the wheel. ### Key dependencies diff --git a/build.py b/build.py index e4adc13..b47b02e 100644 --- a/build.py +++ b/build.py @@ -66,6 +66,15 @@ def main() -> None: env={**os.environ, "LIBVCELL_VCELL_INSTALL_DIR": str(root_dir / "libvcell" / "vcell_install")}, ) + # On Windows VCell runs BioNetGen as bionetgen/win64Standalone/BNG2.exe, packed by scripts/pack_bionetgen.sh + if sys.platform == "win32": + bng2_exe = root_dir / "libvcell" / "vcell_install" / "bionetgen" / "win64Standalone" / "BNG2.exe" + if not bng2_exe.is_file(): + print( + f"WARNING: {bng2_exe} is missing (run scripts/pack_bionetgen.sh): on Windows, rule-based models " + "will use their stored math instead of regenerating it" + ) + # Build vcell-native as native shared object library install_message_4: str = """ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ diff --git a/libvcell/vcell_install/bionetgen/README.md b/libvcell/vcell_install/bionetgen/README.md index 3a4d4e9..d0ca59e 100644 --- a/libvcell/vcell_install/bionetgen/README.md +++ b/libvcell/vcell_install/bionetgen/README.md @@ -8,8 +8,10 @@ identical in the mac release, and in the win release apart from line endings). VCell runs it to expand a rule-based application's reaction rules into a reaction network when it generates the math (`perl BNG2.pl`), looking for it at `/bionetgen/BNG2.pl`; libvcell points `vcell.installDir` at this package's `vcell_install/`. Only network generation is used, so BioNetGen's compiled simulators (`bin/`) are -not included. It needs `perl` on the `PATH` (macOS and most Linux have it; on Windows, e.g. Strawberry Perl). Without -it libvcell falls back to the math stored in the document and says so. +not included. It needs `perl` on the `PATH` on macOS and Linux (they have it). On Windows VCell runs a standalone executable +instead, `win64Standalone/BNG2.exe`: these same files packed with PAR::Packer by `scripts/pack_bionetgen.sh` in the +Windows CI job (it embeds a Perl interpreter, so Windows needs no Perl; it is a build product, not in git). If +BioNetGen cannot run, libvcell falls back to the math stored in the document and says so. **Checked against VCell's own BioNetGen (2.3.0, `vcell_submodule/bionetgen`)** on the 109 rule-based models with ODE simulations in a 2,730-model VCell corpus (2026-10-23): 103 give byte-identical solver input with either version, and diff --git a/pyproject.toml b/pyproject.toml index 674b5a5..dba1158 100644 --- a/pyproject.toml +++ b/pyproject.toml @@ -17,7 +17,9 @@ include = [ {path="libvcell/lib/libvcell*", format="wheel"}, {path="libvcell/py.typed"}, # BioNetGen (BNG2.pl and its Perl modules), which VCell runs to generate rule-based reaction networks - {path="libvcell/vcell_install/**/*"} + {path="libvcell/vcell_install/**/*"}, + # the packed BioNetGen for Windows (git-ignored, built by scripts/pack_bionetgen.sh in the Windows CI job) + {path="libvcell/vcell_install/bionetgen/win64Standalone/*", format="wheel"} ] [tool.poetry.dependencies] diff --git a/scripts/pack_bionetgen.sh b/scripts/pack_bionetgen.sh new file mode 100755 index 0000000..8a8fabe --- /dev/null +++ b/scripts/pack_bionetgen.sh @@ -0,0 +1,62 @@ +#!/usr/bin/env bash +# Pack the bundled BioNetGen (libvcell/vcell_install/bionetgen: BNG2.pl + Perl2/) into a standalone executable with +# PAR::Packer, so it runs without Perl installed. VCell's Windows code launches bionetgen/win64Standalone/BNG2.exe +# instead of `perl BNG2.pl`, so the Windows wheel needs it; CI runs this on Windows before the native build. +# +# Needs PAR::Packer's `pp` (e.g. `cpanm --notest PAR::Packer`; or set PP to its path). Usage: +# scripts/pack_bionetgen.sh [output] (default: libvcell/vcell_install/bionetgen/win64Standalone/BNG2.exe) +set -euo pipefail + +ROOT_DIR="$( cd "$( dirname "$( dirname "${BASH_SOURCE[0]}" )" )" && pwd )" +BNG_DIR="$ROOT_DIR/libvcell/vcell_install/bionetgen" +OUTPUT="${1:-$BNG_DIR/win64Standalone/BNG2.exe}" +# pp, or PP if set; Strawberry Perl (Windows) installs pp as pp.bat, which Git Bash does not find, so fall back to +# running its pp script through perl +read -ra PP_CMD <<< "${PP:-pp}" +if ! command -v "${PP_CMD[0]}" > /dev/null 2>&1 && command -v perl > /dev/null 2>&1; then + PP_CMD=(perl -S pp) +fi + +mkdir -p "$(dirname "$OUTPUT")" +OUTPUT="$( cd "$(dirname "$OUTPUT")" && pwd )/$(basename "$OUTPUT")" +cd "$BNG_DIR" +# BNG2.pl finds Perl2/ next to itself ($FindBin::RealBin), which a packed executable does not have: embed the modules +# (-I Perl2) and name every one (-M), so modules loaded at run time are packed too. +MODULES=() +while IFS= read -r module; do + MODULES+=(-M "$module") +done < <(cd Perl2 && find . -name "*.pm" | sed 's|^\./||; s|\.pm$||; s|/|::|g' | sort) +"${PP_CMD[@]}" -I Perl2 "${MODULES[@]}" -o "$OUTPUT" BNG2.pl + +# smoke test: the packed executable generates a reaction network using only what it carries +SMOKE_DIR="$(mktemp -d)" +cat > "$SMOKE_DIR/smoke.bngl" <<'BNGL' +begin model +begin parameters + kf 1.0 +end parameters +begin molecule types + A(b) + B(a) +end molecule types +begin seed species + A(b) 10 + B(a) 10 +end seed species +begin reaction rules + A(b) + B(a) <-> A(b!1).B(a!1) kf, kf +end reaction rules +end model +generate_network({overwrite=>1}) +BNGL +if ! (cd "$SMOKE_DIR" && env -u PERL5LIB -u BNGPATH -u BioNetGenRoot "$OUTPUT" smoke.bngl > smoke.log 2>&1); then + cat "$SMOKE_DIR/smoke.log" + echo "the packed BioNetGen failed its smoke test" + exit 1 +fi +if ! grep -q "begin reactions" "$SMOKE_DIR/smoke.net"; then + cat "$SMOKE_DIR/smoke.log" + echo "the packed BioNetGen generated no network" + exit 1 +fi +echo "packed $OUTPUT ($(wc -c < "$OUTPUT") bytes); its smoke test generated a $(grep -c '' "$SMOKE_DIR/smoke.net")-line network" diff --git a/tests/test_libvcell.py b/tests/test_libvcell.py index ffb7607..c62983e 100644 --- a/tests/test_libvcell.py +++ b/tests/test_libvcell.py @@ -1,9 +1,12 @@ +import platform import shutil import tempfile +from importlib.resources import files from pathlib import Path import pytest +import libvcell from libvcell import ( VCellExpressionError, evaluate_expression, @@ -304,8 +307,17 @@ def test_sbml_to_ode_input_refuses_a_non_positive_duration(temp_output_dir: Path assert "must be positive" in msg +def _bundled_bionetgen_runs() -> bool: + """VCell runs the packed bionetgen/win64Standalone/BNG2.exe on Windows (scripts/pack_bionetgen.sh), and + `perl BNG2.pl` elsewhere.""" + bionetgen = files(libvcell).joinpath("vcell_install", "bionetgen") + if platform.system() == "Windows": + return bionetgen.joinpath("win64Standalone", "BNG2.exe").is_file() + return shutil.which("perl") is not None + + @_skip_no_ode -@pytest.mark.skipif(shutil.which("perl") is None, reason="BioNetGen runs with perl") +@pytest.mark.skipif(not _bundled_bionetgen_runs(), reason="needs perl, or the packed BNG2.exe on Windows") def test_vcml_to_ode_input_regenerates_a_rule_based_application_with_the_bundled_bionetgen( temp_output_dir: Path, rule_based_vcml_file_path: Path ) -> None: From 7933fc7accd56329db72f0b6a7814130f444a57e Mon Sep 17 00:00:00 2001 From: Jim Schaff Date: Fri, 23 Oct 2026 23:48:16 -0400 Subject: [PATCH 3/3] ci: pack BioNetGen with Strawberry Perl; drop the tmate step from main.yml Git Bash puts the Perl that ships with Git for Windows first on the PATH, so cpanm ran under it and failed (no ExtUtils::Manifest); the Windows pack step now puts Strawberry Perl first and runs cpanm and pp through it. main.yml opened a tmate debug session on every failure and waited for a connection, holding the job (and the runner) until it timed out. The release workflow's tmate step stays: it is opt-in (debug_tmate) and limited to 30 minutes. Co-Authored-By: Claude Opus 5.5 --- .github/workflows/main.yml | 14 ++++++-------- .github/workflows/on-release-main.yml | 8 ++++++-- 2 files changed, 12 insertions(+), 10 deletions(-) diff --git a/.github/workflows/main.yml b/.github/workflows/main.yml index d577b49..49472bf 100644 --- a/.github/workflows/main.yml +++ b/.github/workflows/main.yml @@ -87,8 +87,12 @@ jobs: # VCell runs bionetgen/win64Standalone/BNG2.exe on Windows, not perl BNG2.pl (scripts/pack_bionetgen.sh) if: runner.os == 'Windows' && steps.bionetgen-exe.outputs.cache-hit != 'true' run: | - cpanm --notest PAR::Packer - scripts/pack_bionetgen.sh + # Strawberry Perl, not the Perl that ships with Git for Windows (Git Bash puts its own first, and it lacks + # the modules cpanm and PAR::Packer need) + export PATH="/c/Strawberry/perl/bin:/c/Strawberry/perl/site/bin:/c/Strawberry/c/bin:$PATH" + perl -v | head -2 + perl -S cpanm --notest PAR::Packer + PP="perl -S pp" scripts/pack_bionetgen.sh - name: Install python dependencies run: poetry install --no-interaction @@ -103,12 +107,6 @@ jobs: uses: codecov/codecov-action@v4 if: ${{ matrix.python-version == '3.11' }} - - name: Setup tmate - if: failure() - uses: mxschmitt/action-tmate@v3 - with: - limit-access-to-actor: true - check-docs: runs-on: ubuntu-latest steps: diff --git a/.github/workflows/on-release-main.yml b/.github/workflows/on-release-main.yml index 7a0b127..129964b 100644 --- a/.github/workflows/on-release-main.yml +++ b/.github/workflows/on-release-main.yml @@ -106,8 +106,12 @@ jobs: # VCell runs bionetgen/win64Standalone/BNG2.exe on Windows, not perl BNG2.pl (scripts/pack_bionetgen.sh) if: runner.os == 'Windows' && steps.bionetgen-exe.outputs.cache-hit != 'true' run: | - cpanm --notest PAR::Packer - scripts/pack_bionetgen.sh + # Strawberry Perl, not the Perl that ships with Git for Windows (Git Bash puts its own first, and it lacks + # the modules cpanm and PAR::Packer need) + export PATH="/c/Strawberry/perl/bin:/c/Strawberry/perl/site/bin:/c/Strawberry/c/bin:$PATH" + perl -v | head -2 + perl -S cpanm --notest PAR::Packer + PP="perl -S pp" scripts/pack_bionetgen.sh - name: Run cibuildwheel if: ${{ !startsWith(matrix.os, 'ubuntu') }}