AI-Genetic-Pro
view release on metacpan or search on metacpan
Revision history for Perl extension AI::Genetic::Pro.
1.009 Mon, 09 Jan 2023 21:53:41 +0100
- First release with Dist::Zilla.
1.008 Thu, 05 Jan 2023 11:16:26 +0100
- Fix: MANIFEST
1.007 Sun, 16 Oct 2022 15:16:41 +0200
- One more mprovement.
1.006 Sun, 16 Oct 2022 15:02:03 +0200
- Improvements in a range of efficiency (thanks to Mario Roy :-)
1.005 Tue, 08 Dec 2020 21:32:15 +0100
- Fixed some bugs in a documentation.
1.004 Sun, 15 Nov 2020 14:18:24 +0100
- Added specification of required MCE version.
1.003 Sun, 15 Nov 2020 09:14:05 +0100
- Fixed bug causing "internal error" in a case of cloning raw chromosomes.
1.002 Sat, 14 Nov 2020 21:33:38 +0100
- Fixed bug in a documentation.
1.001 Sat, 14 Nov 2020 19:20:53 +0100
- Fixed bug in a documentation.
1.000 Sat, 14 Nov 2020 18:03:39 +0100
- Added support (long awaited ;) for multi-core processing, through MCE.
- Added direct support for native arrays instead of packed scalars (for chromosomes).
- Some bug fixes.
0.401 Fri, 19 Nov 2011 19:22:45 +0100
- Some bug fixes.
0.341 Mon, 23 Mar 2009 17:21:52 +0100
- Fixed bug in a documentation. Thanks to Randal L. Schwartz :-)
0.34 Tue, 17 Mar 2009 20:39:16 +0100
- Fixed bug in PMX strategy. Thanks to Maciej Misiak :-)
0.335 Sat, 07 Feb 2009 20:04:52 +0100
- Little changes in a Makefile.PL (especially for Sun Solaris)
0.334 Fri, 23 Jan 2009 00:03:26 +0100
- Module 'Digest::MD5' is loaded by default,
0.333 Fri, 22 Jan 2009 15:30:06 +0100
- Some improvments in 'getFittest' function,
- Added 'getFittest_as_arrayref' function,
0.332 Wed, 21 Jan 2009 00:31:01 +0100
- Some changes in tests.
0.331 Tue, 20 Jan 2009 23:55:20 +0100
- Added tests.
- Some improvments in the 'inject' function.
0.33 Mon, 19 Jan 2009 00:38:06 +0100
- Added 'strict' mode.
- Added 'inject' function.
0.32 Sun, 18 Jan 2009 01:16:37 +0100
- Fixes in rangevectors.
0.31 Sat, 17 Jan 2009 20:32:27 +0100
- Fixes in mutation. Added changing of fitness for mutated chromosomes.
0.30 Fri, 16 Jan 2009 00:06:29 +0100
- Fixes in as_string method.
0.29 Thu, 15 Jan 2009 21:13:15 +0100
- Added full support for variable-length chromosomes.
0.28
- Little fixes. Again :-)
0.27
- Little fixes.
0.26 Sun, 11 Jan 2009 22:04:26 +0100
- Little modifications in crossover.
- Added supprot for variable-length chromosomes. Thanks to Leonid Zamdborg :-)
0.25 Mon, 24 Nov 2008 18:57:27 +0100
- Little fix in a counter of generations.
0.24 Mon, 10 Nov 2008 11:34:12 +0100
- Little speed up in main loop.
0.23 Mon, 10 Nov 2008 10:14:32 +0100
- Little modification in main loop. Infinity loop available.
0.22 Wed, 05 Nov 2008 00:49:18 +0100
- Added "-preserve" parameter.
- Little speed up (Class::Accessor::Fast => Class::Accessor::Fast::XS).
0.21 Fri, 10 Oct 2008 03:41:39 +0200
- Fixed mutation in rangevectors. Thanks to Christoph Meissner :-)
0.20 Sat, 04 Oct 2008 02:39:28 +0200
- Again... Little bug in mutation (inversion; listvectors only) - fixed. Thanks to Alec Chen :-)
0.19 Wed, 24 Sep 2008 19:52:33 +0200
- Little bug in mutation - fixed. Thanks to Alec Chen :-)
0.18 Fri, 19 Sep 2008 21:41:46 +0200
- Little fixes in documentation.
0.17 Fri, 19 Sep 2008 03:52:21 +0200
- Added documentation :-)
0.16 Mon, 15 Sep 2008 12:12:44 +0200
- Increased speed during chart generation.
- More documentation.
- Feature 'say' removed for compatibility.
0.15 Sun, 14 Sep 2008 02:14:02 +0200
- Increased speed :-)
- Changes way of mutation is made.
- Added charts.
- Added possibility to save/load GA.
- More documentation.
0.1 Sat, 13 Sep 2008 02:04:25 +0200
- First release.
This software is Copyright (c) 2023 by Åukasz Strzelecki.
This is free software, licensed under:
The GNU Lesser General Public License, Version 2.1, February 1999
The GNU Lesser General Public License (LGPL)
Version 2.1, February 1999
(The master copy of this license lives on the GNU website.)
Copyright (C) 1991, 1999 Free Software Foundation, Inc. 59
51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
Everyone is permitted to copy and distribute verbatim copies
of this license document, but changing it is not allowed.
[This is the first released version of the Lesser GPL. It also
counts as the successor of the GNU Library Public License,
version 2, hence the version number 2.1.]
You may charge a fee for the physical act of transferring a
copy, and you may at your option offer warranty protection in
exchange for a fee.
2. You may modify your copy or copies of the Library or any
portion of it, thus forming a work based on the Library, and
copy and distribute such modifications or work under the
terms of Section 1 above, provided that you also meet all of
these conditions:
a) The modified work must itself be a software
library.
b) You must cause the files modified to carry
prominent notices stating that you changed the
files and the date of any change.
c) You must cause the whole of the work to be
licensed at no charge to all third parties under
the terms of this License.
d) If a facility in the modified Library refers to a
function or a table of data to be supplied by an
application program that uses the facility, other
than as an argument passed when the facility
is invoked, then you must make a good faith
effort to ensure that, in the event an application
does not supply such function or table, the
facility still operates, and performs whatever
part of its purpose remains meaningful.
(For example, a function in a library to
compute square roots has a purpose that is
entirely well-defined independent of the
application. Therefore, Subsection 2d requires
that any application-supplied function or table
used by this function must be optional: if the
application does not supply it, the square root
function must still compute square roots.)
These requirements apply to the modified work
as a whole. If identifiable sections of that work
are not derived from the Library, and can be
reasonably considered independent and
separate works in themselves, then this
License, and its terms, do not apply to those
sections when you distribute them as separate
works. But when you distribute the same
sections as part of a whole which is a work
based on the Library, the distribution of the
whole must be on the terms of this License,
whose permissions for other licensees extend
to the entire whole, and thus to each and every
part regardless of who wrote it.
Thus, it is not the intent of this section to claim
rights or contest your rights to work written
entirely by you; rather, the intent is to exercise
the right to control the distribution of derivative
or collective works based on the Library.
In addition, mere aggregation of another work
not based on the Library with the Library (or
with a work based on the Library) on a volume
of a storage or distribution medium does not
bring the other work under the scope of this
License.
3. You may opt to apply the terms of the ordinary GNU
General Public License instead of this License to a given
copy of the Library. To do this, you must alter all the notices
that refer to this License, so that they refer to the ordinary
GNU General Public License, version 2, instead of to this
License. (If a newer version than version 2 of the ordinary
GNU General Public License has appeared, then you can
specify that version instead if you wish.) Do not make any
other change in these notices.
such modifications.
You must give prominent notice with each copy of the work
that the Library is used in it and that the Library and its use
are covered by this License. You must supply a copy of this
License. If the work during execution displays copyright
notices, you must include the copyright notice for the Library
among them, as well as a reference directing the user to the
copy of this License. Also, you must do one of these things:
a) Accompany the work with the complete
corresponding machine-readable source code
for the Library including whatever changes were
used in the work (which must be distributed
under Sections 1 and 2 above); and, if the work
is an executable linked with the Library, with
the complete machine-readable "work that
uses the Library", as object code and/or
source code, so that the user can modify the
Library and then relink to produce a modified
executable containing the modified Library. (It
is understood that the user who changes the
contents of definitions files in the Library will
not necessarily be able to recompile the
application to use the modified definitions.)
b) Use a suitable shared library mechanism for
linking with the Library. A suitable mechanism
is one that (1) uses at run time a copy of the
library already present on the user's computer
system, rather than copying library functions
into the executable, and (2) will operate
properly with a modified version of the library, if
the user installs one, as long as the modified
version is interface-compatible with the version
that the work was made with.
c) Accompany the work with a written offer,
valid for at least three years, to give the same
user the materials specified in Subsection 6a,
above, for a charge no more than the cost of
performing this distribution.
d) If distribution of the work is made by offering
access to copy from a designated place, offer
equivalent access to copy the above specified
materials from the same place.
e) Verify that the user has already received a
copy of these materials or that you have
already sent this user a copy.
For an executable, the required form of the "work that uses
the Library" must include any data and utility programs
needed for reproducing the executable from it. However, as a
special exception, the materials to be distributed need not
include anything that is normally distributed (in either source
or binary form) with the major components (compiler, kernel,
and so on) of the operating system on which the executable
runs, unless that component itself accompanies the
executable.
an executable that you distribute.
7. You may place library facilities that are a work based on
the Library side-by-side in a single library together with other
library facilities not covered by this License, and distribute
such a combined library, provided that the separate
distribution of the work based on the Library and of the other
library facilities is otherwise permitted, and provided that you
do these two things:
a) Accompany the combined library with a
copy of the same work based on the Library,
uncombined with any other library facilities.
This must be distributed under the terms of the
Sections above.
b) Give prominent notice with the combined
library of the fact that part of it is a work based
on the Library, and explaining where to find the
accompanying uncombined form of the same
work.
8. You may not copy, modify, sublicense, link with, or
distribute the Library except as expressly provided under this
License. Any attempt otherwise to copy, modify, sublicense,
link with, or distribute the Library is void, and will
automatically terminate your rights under this License.
However, parties who have received copies, or rights, from
you under this License will not have their licenses terminated
so long as such parties remain in full compliance.
{
"abstract" : "Efficient genetic algorithms for professional purpose with support for multiprocessing.",
"author" : [
"\u0141ukasz Strzelecki <lukasz@strzeleccy.eu>"
],
"dynamic_config" : 0,
"generated_by" : "Dist::Zilla version 6.017, CPAN::Meta::Converter version 2.150010",
"license" : [
"lgpl_2_1"
],
"meta-spec" : {
"url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec",
"version" : 2
},
"name" : "AI-Genetic-Pro",
"prereqs" : {
"configure" : {
"requires" : {
"ExtUtils::MakeMaker" : "0"
}
},
"runtime" : {
"requires" : {
"Carp" : "0",
"Class::Accessor::Fast::XS" : "0",
"Clone" : "0",
"Digest::MD5" : "0",
"Exporter::Lite" : "0",
"GD::Graph::linespoints" : "1.54",
"List::MoreUtils" : "0",
"List::Util" : "0",
"MCE" : "1.874",
"MCE::Map" : "1.874",
"Math::Random" : "0.72",
"Storable" : "2.05",
"Struct::Compare" : "0",
"Tie::Array::Packed" : "0.13",
"UNIVERSAL::require" : "0"
}
}
},
"release_status" : "stable",
"resources" : {
"homepage" : "https://github.com/d-strzelec/AI-Genetic-Pro",
"repository" : {
"type" : "git",
"url" : "https://github.com/d-strzelec/AI-Genetic-Pro.git",
"web" : "https://github.com/d-strzelec/AI-Genetic-Pro"
}
},
"version" : "1.009",
"x_Dist_Zilla" : {
"perl" : {
"version" : "5.032001"
},
"plugins" : [
{
"class" : "Dist::Zilla::Plugin::GatherDir",
"config" : {
"Dist::Zilla::Plugin::GatherDir" : {
"exclude_filename" : [],
"exclude_match" : [],
"follow_symlinks" : 0,
"include_dotfiles" : 0,
"prefix" : "",
"prune_directory" : [],
"root" : "."
}
},
"name" : "GatherDir",
"version" : "6.017"
},
{
"class" : "Dist::Zilla::Plugin::PruneCruft",
"name" : "PruneCruft",
"version" : "6.017"
},
{
"class" : "Dist::Zilla::Plugin::PruneFiles",
"name" : "PruneFiles",
"version" : "6.017"
},
{
"class" : "Dist::Zilla::Plugin::ManifestSkip",
"name" : "ManifestSkip",
"version" : "6.017"
},
{
"class" : "Dist::Zilla::Plugin::MetaYAML",
"name" : "MetaYAML",
"version" : "6.017"
},
{
"class" : "Dist::Zilla::Plugin::MetaJSON",
"name" : "MetaJSON",
"version" : "6.017"
},
{
"class" : "Dist::Zilla::Plugin::License",
"name" : "License",
"version" : "6.017"
},
{
"class" : "Dist::Zilla::Plugin::MakeMaker",
"config" : {
"Dist::Zilla::Role::TestRunner" : {
"default_jobs" : 1
}
},
"name" : "MakeMaker",
"version" : "6.017"
},
{
"class" : "Dist::Zilla::Plugin::Manifest",
"name" : "Manifest",
"version" : "6.017"
},
{
"class" : "Dist::Zilla::Plugin::PkgVersion",
"name" : "PkgVersion",
"version" : "6.017"
},
{
"class" : "Dist::Zilla::Plugin::ReadmeFromPod",
"name" : "ReadmeFromPod",
"version" : "0.37"
},
{
"class" : "Dist::Zilla::Plugin::MetaConfig",
"name" : "MetaConfig",
"version" : "6.017"
},
{
"class" : "Dist::Zilla::Plugin::Prereqs",
"config" : {
"Dist::Zilla::Plugin::Prereqs" : {
"phase" : "runtime",
"type" : "requires"
}
},
"name" : "Prereqs",
"version" : "6.017"
},
{
"class" : "Dist::Zilla::Plugin::GithubMeta",
"name" : "GithubMeta",
"version" : "0.58"
},
{
"class" : "Dist::Zilla::Plugin::Git::Commit",
"config" : {
"Dist::Zilla::Plugin::Git::Commit" : {
"add_files_in" : [],
"commit_msg" : "Release v%v%n%n%c",
"signoff" : 0
},
"Dist::Zilla::Role::Git::DirtyFiles" : {
"allow_dirty" : [
"Changes",
"dist.ini"
],
"allow_dirty_match" : [
"(?^u:.*(?:\\.pm|README|\\*.t)$)"
],
"changelog" : "Changes"
},
"Dist::Zilla::Role::Git::Repo" : {
"git_version" : "2.30.2",
"repo_root" : "."
},
"Dist::Zilla::Role::Git::StringFormatter" : {
"time_zone" : "local"
}
},
"name" : "Git::Commit",
"version" : "2.047"
},
{
"class" : "Dist::Zilla::Plugin::Git::Push",
"config" : {
"Dist::Zilla::Plugin::Git::Push" : {
"push_to" : [
"d-strzelec"
],
"remotes_must_exist" : 1
},
"Dist::Zilla::Role::Git::Repo" : {
"git_version" : "2.30.2",
"repo_root" : "."
}
},
"name" : "Git::Push",
"version" : "2.047"
},
{
"class" : "Dist::Zilla::Plugin::TestRelease",
"name" : "TestRelease",
"version" : "6.017"
},
{
"class" : "Dist::Zilla::Plugin::ConfirmRelease",
"name" : "ConfirmRelease",
"version" : "6.017"
},
{
"class" : "Dist::Zilla::Plugin::UploadToCPAN",
"name" : "UploadToCPAN",
"version" : "6.017"
},
{
"class" : "Dist::Zilla::Plugin::FinderCode",
"name" : ":InstallModules",
"version" : "6.017"
},
{
"class" : "Dist::Zilla::Plugin::FinderCode",
"name" : ":IncModules",
"version" : "6.017"
},
{
"class" : "Dist::Zilla::Plugin::FinderCode",
"name" : ":TestFiles",
"version" : "6.017"
},
{
"class" : "Dist::Zilla::Plugin::FinderCode",
"name" : ":ExtraTestFiles",
"version" : "6.017"
},
{
"class" : "Dist::Zilla::Plugin::FinderCode",
"name" : ":ExecFiles",
"version" : "6.017"
},
{
"class" : "Dist::Zilla::Plugin::FinderCode",
"name" : ":PerlExecFiles",
"version" : "6.017"
},
{
"class" : "Dist::Zilla::Plugin::FinderCode",
"name" : ":ShareFiles",
"version" : "6.017"
},
{
"class" : "Dist::Zilla::Plugin::FinderCode",
"name" : ":MainModule",
"version" : "6.017"
},
{
"class" : "Dist::Zilla::Plugin::FinderCode",
"name" : ":AllFiles",
"version" : "6.017"
},
{
"class" : "Dist::Zilla::Plugin::FinderCode",
"name" : ":NoFiles",
"version" : "6.017"
}
],
"zilla" : {
"class" : "Dist::Zilla::Dist::Builder",
"config" : {
"is_trial" : 0
},
"version" : "6.017"
}
},
"x_generated_by_perl" : "v5.32.1",
"x_serialization_backend" : "Cpanel::JSON::XS version 4.25",
"x_spdx_expression" : "LGPL-2.1"
}
---
abstract: 'Efficient genetic algorithms for professional purpose with support for multiprocessing.'
author:
- 'Åukasz Strzelecki <lukasz@strzeleccy.eu>'
build_requires: {}
configure_requires:
ExtUtils::MakeMaker: '0'
dynamic_config: 0
generated_by: 'Dist::Zilla version 6.017, CPAN::Meta::Converter version 2.150010'
license: lgpl
meta-spec:
url: http://module-build.sourceforge.net/META-spec-v1.4.html
version: '1.4'
name: AI-Genetic-Pro
requires:
Carp: '0'
Class::Accessor::Fast::XS: '0'
Clone: '0'
Digest::MD5: '0'
Exporter::Lite: '0'
GD::Graph::linespoints: '1.54'
List::MoreUtils: '0'
List::Util: '0'
MCE: '1.874'
MCE::Map: '1.874'
Math::Random: '0.72'
Storable: '2.05'
Struct::Compare: '0'
Tie::Array::Packed: '0.13'
UNIVERSAL::require: '0'
resources:
homepage: https://github.com/d-strzelec/AI-Genetic-Pro
repository: https://github.com/d-strzelec/AI-Genetic-Pro.git
version: '1.009'
x_Dist_Zilla:
perl:
version: '5.032001'
plugins:
-
class: Dist::Zilla::Plugin::GatherDir
config:
Dist::Zilla::Plugin::GatherDir:
exclude_filename: []
exclude_match: []
follow_symlinks: 0
include_dotfiles: 0
prefix: ''
prune_directory: []
root: .
name: GatherDir
version: '6.017'
-
class: Dist::Zilla::Plugin::PruneCruft
name: PruneCruft
version: '6.017'
-
class: Dist::Zilla::Plugin::PruneFiles
name: PruneFiles
version: '6.017'
-
class: Dist::Zilla::Plugin::ManifestSkip
name: ManifestSkip
version: '6.017'
-
class: Dist::Zilla::Plugin::MetaYAML
name: MetaYAML
version: '6.017'
-
class: Dist::Zilla::Plugin::MetaJSON
name: MetaJSON
version: '6.017'
-
class: Dist::Zilla::Plugin::License
name: License
version: '6.017'
-
class: Dist::Zilla::Plugin::MakeMaker
config:
Dist::Zilla::Role::TestRunner:
default_jobs: 1
name: MakeMaker
version: '6.017'
-
class: Dist::Zilla::Plugin::Manifest
name: Manifest
version: '6.017'
-
class: Dist::Zilla::Plugin::PkgVersion
name: PkgVersion
version: '6.017'
-
class: Dist::Zilla::Plugin::ReadmeFromPod
name: ReadmeFromPod
version: '0.37'
-
class: Dist::Zilla::Plugin::MetaConfig
name: MetaConfig
version: '6.017'
-
class: Dist::Zilla::Plugin::Prereqs
config:
Dist::Zilla::Plugin::Prereqs:
phase: runtime
type: requires
name: Prereqs
version: '6.017'
-
class: Dist::Zilla::Plugin::GithubMeta
name: GithubMeta
version: '0.58'
-
class: Dist::Zilla::Plugin::Git::Commit
config:
Dist::Zilla::Plugin::Git::Commit:
add_files_in: []
commit_msg: 'Release v%v%n%n%c'
signoff: 0
Dist::Zilla::Role::Git::DirtyFiles:
allow_dirty:
- Changes
- dist.ini
allow_dirty_match:
- (?^u:.*(?:\.pm|README|\*.t)$)
changelog: Changes
Dist::Zilla::Role::Git::Repo:
git_version: 2.30.2
repo_root: .
Dist::Zilla::Role::Git::StringFormatter:
time_zone: local
name: Git::Commit
version: '2.047'
-
class: Dist::Zilla::Plugin::Git::Push
config:
Dist::Zilla::Plugin::Git::Push:
push_to:
- d-strzelec
remotes_must_exist: 1
Dist::Zilla::Role::Git::Repo:
git_version: 2.30.2
repo_root: .
name: Git::Push
version: '2.047'
-
class: Dist::Zilla::Plugin::TestRelease
name: TestRelease
version: '6.017'
-
class: Dist::Zilla::Plugin::ConfirmRelease
name: ConfirmRelease
version: '6.017'
-
class: Dist::Zilla::Plugin::UploadToCPAN
name: UploadToCPAN
version: '6.017'
-
class: Dist::Zilla::Plugin::FinderCode
name: ':InstallModules'
version: '6.017'
-
class: Dist::Zilla::Plugin::FinderCode
name: ':IncModules'
version: '6.017'
-
class: Dist::Zilla::Plugin::FinderCode
name: ':TestFiles'
version: '6.017'
-
class: Dist::Zilla::Plugin::FinderCode
name: ':ExtraTestFiles'
version: '6.017'
-
class: Dist::Zilla::Plugin::FinderCode
name: ':ExecFiles'
version: '6.017'
-
class: Dist::Zilla::Plugin::FinderCode
name: ':PerlExecFiles'
version: '6.017'
-
class: Dist::Zilla::Plugin::FinderCode
name: ':ShareFiles'
version: '6.017'
-
class: Dist::Zilla::Plugin::FinderCode
name: ':MainModule'
version: '6.017'
-
class: Dist::Zilla::Plugin::FinderCode
name: ':AllFiles'
version: '6.017'
-
class: Dist::Zilla::Plugin::FinderCode
name: ':NoFiles'
version: '6.017'
zilla:
class: Dist::Zilla::Dist::Builder
config:
is_trial: '0'
version: '6.017'
x_generated_by_perl: v5.32.1
x_serialization_backend: 'YAML::Tiny version 1.73'
x_spdx_expression: LGPL-2.1
Makefile.PL view on Meta::CPAN
# This file was automatically generated by Dist::Zilla::Plugin::MakeMaker v6.017.
use strict;
use warnings;
use ExtUtils::MakeMaker;
my %WriteMakefileArgs = (
"ABSTRACT" => "Efficient genetic algorithms for professional purpose with support for multiprocessing.",
"AUTHOR" => "\x{141}ukasz Strzelecki <lukasz\@strzeleccy.eu>",
"CONFIGURE_REQUIRES" => {
"ExtUtils::MakeMaker" => 0
},
"DISTNAME" => "AI-Genetic-Pro",
"LICENSE" => "lgpl",
"NAME" => "AI::Genetic::Pro",
"PREREQ_PM" => {
"Carp" => 0,
"Class::Accessor::Fast::XS" => 0,
"Clone" => 0,
"Digest::MD5" => 0,
"Exporter::Lite" => 0,
"GD::Graph::linespoints" => "1.54",
"List::MoreUtils" => 0,
"List::Util" => 0,
"MCE" => "1.874",
"MCE::Map" => "1.874",
"Math::Random" => "0.72",
"Storable" => "2.05",
"Struct::Compare" => 0,
"Tie::Array::Packed" => "0.13",
"UNIVERSAL::require" => 0
},
"VERSION" => "1.009",
"test" => {
"TESTS" => "t/*.t"
}
);
my %FallbackPrereqs = (
"Carp" => 0,
"Class::Accessor::Fast::XS" => 0,
"Clone" => 0,
"Digest::MD5" => 0,
"Exporter::Lite" => 0,
"GD::Graph::linespoints" => "1.54",
"List::MoreUtils" => 0,
"List::Util" => 0,
"MCE" => "1.874",
"MCE::Map" => "1.874",
"Math::Random" => "0.72",
"Storable" => "2.05",
"Struct::Compare" => 0,
"Tie::Array::Packed" => "0.13",
"UNIVERSAL::require" => 0
);
unless ( eval { ExtUtils::MakeMaker->VERSION(6.63_03) } ) {
delete $WriteMakefileArgs{TEST_REQUIRES};
delete $WriteMakefileArgs{BUILD_REQUIRES};
$WriteMakefileArgs{PREREQ_PM} = \%FallbackPrereqs;
}
delete $WriteMakefileArgs{CONFIGURE_REQUIRES}
unless eval { ExtUtils::MakeMaker->VERSION(6.52) };
WriteMakefile(%WriteMakefileArgs);
NAME
AI::Genetic::Pro - Efficient genetic algorithms for professional
purpose with support for multiprocessing.
SYNOPSIS
use AI::Genetic::Pro;
sub fitness {
my ($ga, $chromosome) = @_;
return oct('0b' . $ga->as_string($chromosome));
}
sub terminate {
my ($ga) = @_;
my $result = oct('0b' . $ga->as_string($ga->getFittest));
return $result == 4294967295 ? 1 : 0;
}
my $ga = AI::Genetic::Pro->new(
-fitness => \&fitness, # fitness function
-terminate => \&terminate, # terminate function
-type => 'bitvector', # type of chromosomes
-population => 1000, # population
-crossover => 0.9, # probab. of crossover
-mutation => 0.01, # probab. of mutation
-parents => 2, # number of parents
-selection => [ 'Roulette' ], # selection strategy
-strategy => [ 'Points', 2 ], # crossover strategy
-cache => 0, # cache results
-history => 1, # remember best results
-preserve => 3, # remember the bests
-variable_length => 1, # turn variable length ON
-mce => 1, # optional MCE support
-workers => 3, # number of workers (MCE)
);
# init population of 32-bit vectors
$ga->init(32);
# evolve 10 generations
$ga->evolve(10);
# best score
print "SCORE: ", $ga->as_value($ga->getFittest), ".\n";
# save evolution path as a chart
$ga->chart(-filename => 'evolution.png');
# save state of GA
$ga->save('genetic.sga');
# load state of GA
$ga->load('genetic.sga');
DESCRIPTION
This module provides efficient implementation of a genetic algorithm
for professional purpose with support for multiprocessing. It was
designed to operate as fast as possible even on very large populations
and big individuals/chromosomes. AI::Genetic::Pro was inspired by
AI::Genetic, so it is in most cases compatible (there are some
changes). Additionally AI::Genetic::Pro isn't a pure Perl solution, so
it doesn't have limitations of its ancestor (such as slow-down in the
case of big populations ( >10000 ) or vectors with more than 33
fields).
If You are looking for a pure Perl solution, consider AI::Genetic.
Speed
To increase speed XS code is used, however with portability in mind.
This distribution was tested on Windows and Linux platforms (and
should work on any other).
Multicore support is available through Many-Core Engine (MCE). You
can gain the most speed up for big populations or time/CPU consuming
fitness functions, however for small populations and/or simple
fitness function better choice will be single-process version.
You can get even more speed up if you turn on use of native arrays
(parameter: native) instead of packing chromosomes into single
scalar. However you have to remember about expensive memory use in
that case.
Memory
This module was designed to use as little memory as possible. A
population of size 10000 consisting of 92-bit vectors uses only ~24MB
(AI::Genetic would use about 78MB). However - if you use MCE - there
will be bigger memory consumption. This is consequence of necessity
of synchronization between many processes.
Advanced options
To provide more flexibility AI::Genetic::Pro supports many
statistical distributions, such as uniform, natural, chi_square and
others. This feature can be used in selection and/or crossover. See
the documentation below.
METHODS
$ga->new( %options )
Constructor. It accepts options in hash-value style. See options and
an example below.
-fitness
This defines a fitness function. It expects a reference to a
subroutine.
-terminate
This defines a terminate function. It expects a reference to a
subroutine.
-type
This defines the type of chromosomes. Currently, AI::Genetic::Pro
supports four types:
bitvector
Individuals/chromosomes of this type have genes that are bits.
Each gene can be in one of two possible states, on or off.
listvector
Each gene of a "listvector" individual/chromosome can assume one
string value from a specified list of possible string values.
rangevector
Each gene of a "rangevector" individual/chromosome can assume one
integer value from a range of possible integer values. Note that
only integers are supported. The user can always transform any
desired fractional values by multiplying and dividing by an
appropriate power of 10.
combination
Each gene of a "combination" individual/chromosome can assume one
string value from a specified list of possible string values. All
genes are unique.
-population
This defines the size of the population, i.e. how many chromosomes
simultaneously exist at each generation.
-crossover
This defines the crossover rate. The fairest results are achieved
with crossover rate ~0.95.
-mutation
This defines the mutation rate. The fairest results are achieved
with mutation rate ~0.01.
-preserve
This defines injection of the bests chromosomes into a next
generation. It causes a little slow down, however (very often) much
better results are achieved. You can specify, how many chromosomes
will be preserved, i.e.
-preserve => 1, # only one chromosome will be preserved
# or
-preserve => 9, # 9 chromosomes will be preserved
# and so on...
Attention! You cannot preserve more chromosomes than exist in your
population.
-variable_length
This defines whether variable-length chromosomes are turned on
(default off) and a which types of mutation are allowed. See below.
level 0
Feature is inactive (default). Example:
-variable_length => 0
# chromosomes (i.e. bitvectors)
0 1 0 0 1 1 0 1 1 1 0 1 0 1
0 0 1 1 0 1 1 1 1 0 0 1 1 0
0 1 1 1 0 1 0 0 1 1 0 1 1 1
0 1 0 0 1 1 0 1 1 1 1 0 1 0
# ...and so on
level 1
Feature is active, but chromosomes can varies only on the right
side, Example:
-variable_length => 1
# chromosomes (i.e. bitvectors)
0 1 0 0 1 1 0 1 1 1
0 0 1 1 0 1 1 1 1
0 1 1 1 0 1 0 0 1 1 0 1 1 1
0 1 0 0 1 1 0 1 1 1
# ...and so on
level 2
Feature is active and chromosomes can varies on the left side and
on the right side; unwanted values/genes on the left side are
replaced with undef, ie.
-variable_length => 2
# chromosomes (i.e. bitvectors)
x x x 0 1 1 0 1 1 1
x x x x 0 1 1 1 1
x 1 1 1 0 1 0 0 1 1 0 1 1 1
0 1 0 0 1 1 0 1 1 1
# where 'x' means 'undef'
# ...and so on
In this situation returned chromosomes in an array context
($ga->as_array($chromosome)) can have undef values on the left
side (only). In a scalar context each undefined value is replaced
with a single space. If You don't want to see any undef or space,
just use as_array_def_only and as_string_def_only instead of
as_array and as_string.
-parents
This defines how many parents should be used in a crossover.
-selection
This defines how individuals/chromosomes are selected to crossover.
It expects an array reference listed below:
-selection => [ $type, @params ]
where type is one of:
RouletteBasic
Each individual/chromosome can be selected with probability
proportional to its fitness.
Roulette
First the best individuals/chromosomes are selected. From this
collection parents are selected with probability poportional to
their fitness.
RouletteDistribution
Each individual/chromosome has a portion of roulette wheel
proportional to its fitness. Selection is done with the specified
distribution. Supported distributions and parameters are listed
below.
-selection => [ 'RouletteDistribution', 'uniform' ]
Standard uniform distribution. No additional parameters are
needed.
-selection => [ 'RouletteDistribution', 'normal', $av, $sd ]
Normal distribution, where $av is average (default: size of
population /2) and $$sd is standard deviation (default: size of
population).
-selection => [ 'RouletteDistribution', 'beta', $aa, $bb ]
Beta distribution. The density of the beta is:
X^($aa - 1) * (1 - X)^($bb - 1) / B($aa , $bb) for 0 < X < 1.
$aa and $bb are set by default to number of parents.
Argument restrictions: Both $aa and $bb must not be less than
1.0E-37.
-selection => [ 'RouletteDistribution', 'binomial' ]
Binomial distribution. No additional parameters are needed.
-selection => [ 'RouletteDistribution', 'chi_square', $df ]
Chi-square distribution with $df degrees of freedom. $df by
default is set to size of population.
-selection => [ 'RouletteDistribution', 'exponential', $av ]
Exponential distribution, where $av is average . $av by default
is set to size of population.
-selection => [ 'RouletteDistribution', 'poisson', $mu ]
Poisson distribution, where $mu is mean. $mu by default is set
to size of population.
Distribution
Chromosomes/individuals are selected with specified distribution.
See below.
-selection => [ 'Distribution', 'uniform' ]
Standard uniform distribution. No additional parameters are
needed.
-selection => [ 'Distribution', 'normal', $av, $sd ]
Normal distribution, where $av is average (default: size of
population /2) and $$sd is standard deviation (default: size of
population).
-selection => [ 'Distribution', 'beta', $aa, $bb ]
Beta distribution. The density of the beta is:
X^($aa - 1) * (1 - X)^($bb - 1) / B($aa , $bb) for 0 < X < 1.
$aa and $bb are set by default to number of parents.
Argument restrictions: Both $aa and $bb must not be less than
1.0E-37.
-selection => [ 'Distribution', 'binomial' ]
Binomial distribution. No additional parameters are needed.
-selection => [ 'Distribution', 'chi_square', $df ]
Chi-square distribution with $df degrees of freedom. $df by
default is set to size of population.
-selection => [ 'Distribution', 'exponential', $av ]
Exponential distribution, where $av is average . $av by default
is set to size of population.
-selection => [ 'Distribution', 'poisson', $mu ]
Poisson distribution, where $mu is mean. $mu by default is set
to size of population.
-strategy
This defines the astrategy of crossover operation. It expects an
array reference listed below:
-strategy => [ $type, @params ]
where type is one of:
PointsSimple
Simple crossover in one or many points. The best
chromosomes/individuals are selected for the new generation. For
example:
-strategy => [ 'PointsSimple', $n ]
where $n is the number of points for crossing.
PointsBasic
Crossover in one or many points. In basic crossover selected
parents are crossed and one (randomly-chosen) child is moved to
the new generation. For example:
-strategy => [ 'PointsBasic', $n ]
where $n is the number of points for crossing.
Points
Crossover in one or many points. In normal crossover selected
parents are crossed and the best child is moved to the new
generation. For example:
-strategy => [ 'Points', $n ]
where $n is number of points for crossing.
PointsAdvenced
Crossover in one or many points. After crossover the best
chromosomes/individuals from all parents and chidren are selected
for the new generation. For example:
-strategy => [ 'PointsAdvanced', $n ]
where $n is the number of points for crossing.
Distribution
In distribution crossover parents are crossed in points selected
with the specified distribution. See below.
-strategy => [ 'Distribution', 'uniform' ]
Standard uniform distribution. No additional parameters are
needed.
-strategy => [ 'Distribution', 'normal', $av, $sd ]
Normal distribution, where $av is average (default: number of
parents/2) and $sd is standard deviation (default: number of
parents).
-strategy => [ 'Distribution', 'beta', $aa, $bb ]
Beta distribution. The density of the beta is:
X^($aa - 1) * (1 - X)^($bb - 1) / B($aa , $bb) for 0 < X < 1.
$aa and $bb are set by default to the number of parents.
Argument restrictions: Both $aa and $bb must not be less than
1.0E-37.
-strategy => [ 'Distribution', 'binomial' ]
Binomial distribution. No additional parameters are needed.
-strategy => [ 'Distribution', 'chi_square', $df ]
Chi-squared distribution with $df degrees of freedom. $df by
default is set to the number of parents.
-strategy => [ 'Distribution', 'exponential', $av ]
Exponential distribution, where $av is average . $av by default
is set to the number of parents.
-strategy => [ 'Distribution', 'poisson', $mu ]
Poisson distribution, where $mu is mean. $mu by default is set
to the number of parents.
PMX
PMX method defined by Goldberg and Lingle in 1985. Parameters:
none.
OX
OX method defined by Davis (?) in 1985. Parameters: none.
-cache
This defines whether a cache should be used. Allowed values are 1
or 0 (default: 0).
-history
This defines whether history should be collected. Allowed values
are 1 or 0 (default: 0).
-native
This defines whether native arrays should be used instead of
packing each chromosome into signle scalar. Turning this option can
give you speed up, but much more memory will be used. Allowed
values are 1 or 0 (default: 0).
-mce
This defines whether Many-Core Engine (MCE) should be used during
processing. This can give you significant speed up on many-core/CPU
systems, but it'll increase memory consumption. Allowed values are
1 or 0 (default: 0).
-workers
This option has any meaning only if MCE is turned on. This defines
how many process will be used during processing. Default will be
used one proces per core (most efficient).
-strict
This defines if the check for modifying chromosomes in a
user-defined fitness function is active. Directly modifying
chromosomes is not allowed and it is a highway to big trouble. This
mode should be used only for testing, because it is slow.
$ga->inject($chromosomes)
Inject new, user defined, chromosomes into the current population.
See example below:
# example for bitvector
my $chromosomes = [
[ 1, 1, 0, 1, 0, 1 ],
[ 0, 0, 0, 1, 0, 1 ],
[ 0, 1, 0, 1, 0, 0 ],
...
];
# inject
$ga->inject($chromosomes);
If You want to delete some chromosomes from population, just splice
them:
my @remove = qw(1 2 3 9 12);
for my $idx (sort { $b <=> $a } @remove){
splice @{$ga->chromosomes}, $idx, 1;
}
$ga->population($population)
Set/get size of the population. This defines the size of the
population, i.e. how many chromosomes to simultaneously exist at each
generation.
$ga->indType()
Get type of individuals/chromosomes. Currently supported types are:
bitvector
Chromosomes will be just bitvectors. See documentation of new
method.
listvector
Chromosomes will be lists of specified values. See documentation of
new method.
rangevector
Chromosomes will be lists of values from specified range. See
documentation of new method.
combination
Chromosomes will be unique lists of specified values. This is used
for example in the Traveling Salesman Problem. See the
documentation of the new method.
In example:
my $type = $ga->type();
$ga->type()
Alias for indType.
$ga->crossProb()
This method is used to query and set the crossover rate.
$ga->crossover()
Alias for crossProb.
$ga->mutProb()
This method is used to query and set the mutation rate.
$ga->mutation()
Alias for mutProb.
$ga->parents($parents)
Set/get number of parents in a crossover.
$ga->init($args)
This method initializes the population with random
individuals/chromosomes. It MUST be called before any call to
evolve(). It expects one argument, which depends on the type of
individuals/chromosomes:
bitvector
For bitvectors, the argument is simply the length of the bitvector.
$ga->init(10);
This initializes a population where each individual/chromosome has
10 genes.
listvector
For listvectors, the argument is an anonymous list of lists. The
number of sub-lists is equal to the number of genes of each
individual/chromosome. Each sub-list defines the possible string
values that the corresponding gene can assume.
$ga->init([
[qw/red blue green/],
[qw/big medium small/],
[qw/very_fat fat fit thin very_thin/],
]);
This initializes a population where each individual/chromosome has
3 genes and each gene can assume one of the given values.
rangevector
For rangevectors, the argument is an anonymous list of lists. The
number of sub-lists is equal to the number of genes of each
individual/chromosome. Each sub-list defines the minimum and
maximum integer values that the corresponding gene can assume.
$ga->init([
[1, 5],
[0, 20],
[4, 9],
]);
This initializes a population where each individual/chromosome has
3 genes and each gene can assume an integer within the
corresponding range.
combination
For combination, the argument is an anonymous list of possible
values of gene.
$ga->init( [ 'a', 'b', 'c' ] );
This initializes a population where each chromosome has 3 genes and
each gene is a unique combination of 'a', 'b' and 'c'. For example
genes looks something like that:
[ 'a', 'b', 'c' ] # gene 1
[ 'c', 'a', 'b' ] # gene 2
[ 'b', 'c', 'a' ] # gene 3
# ...and so on...
$ga->evolve($n)
This method causes the GA to evolve the population for the specified
number of generations. If its argument is 0 or undef GA will evolve
the population to infinity unless a terminate function is specified.
$ga->getHistory()
Get history of the evolution. It is in a format listed below:
[
# gen0 gen1 gen2 ... # generations
[ max0, max1, max2, ... ], # max values
[ mean, mean1, mean2, ... ], # mean values
[ min0, min1, min2, ... ], # min values
]
$ga->getAvgFitness()
Get max, mean and min score of the current generation. In example:
my ($max, $mean, $min) = $ga->getAvgFitness();
$ga->getFittest($n, $unique)
This function returns a list of the fittest chromosomes from the
current population. You can specify how many chromosomes should be
returned and if the returned chromosomes should be unique. See
example below.
# only one - the best
my ($best) = $ga->getFittest;
# or 5 bests chromosomes, NOT unique
my @bests = $ga->getFittest(5);
# or 7 bests and UNIQUE chromosomes
my @bests = $ga->getFittest(7, 1);
If you want to get a large number of chromosomes, try to use the
getFittest_as_arrayref function instead (for efficiency).
$ga->getFittest_as_arrayref($n, $unique)
This function is very similar to getFittest, but it returns a
reference to an array instead of a list.
$ga->generation()
Get the number of the current generation.
$ga->people()
Returns an anonymous list of individuals/chromosomes of the current
population.
IMPORTANT: the actual array reference used by the AI::Genetic::Pro
object is returned, so any changes to it will be reflected in $ga.
$ga->chromosomes()
Alias for people.
$ga->chart(%options)
Generate a chart describing changes of min, mean, and max scores in
your population. To satisfy your needs, you can pass the following
options:
-filename
File to save a chart in (obligatory).
-title
Title of a chart (default: Evolution).
-x_label
X label (default: Generations).
-y_label
Y label (default: Value).
-format
Format of values, like sprintf (default: '%.2f').
-legend1
Description of min line (default: Min value).
-legend2
Description of min line (default: Mean value).
-legend3
Description of min line (default: Max value).
-width
Width of a chart (default: 640).
-height
Height of a chart (default: 480).
-font
Path to font (in *.ttf format) to be used (default: none).
-logo
Path to logo (png/jpg image) to embed in a chart (default: none).
For example:
$ga->chart(-width => 480, height => 320, -filename => 'chart.png');
$ga->save($file)
Save the current state of the genetic algorithm to the specified
file.
$ga->load($file)
Load a state of the genetic algorithm from the specified file.
$ga->as_array($chromosome)
In list context return an array representing the specified
chromosome. In scalar context return an reference to an array
representing the specified chromosome. If variable_length is turned
on and is set to level 2, an array can have some undef values. To get
only not undef values use as_array_def_only instead of as_array.
$ga->as_array_def_only($chromosome)
In list context return an array representing the specified
chromosome. In scalar context return an reference to an array
representing the specified chromosome. If variable_length is turned
off, this function is just an alias for as_array. If variable_length
is turned on and is set to level 2, this function will return only
not undef values from chromosome. See example below:
# -variable_length => 2, -type => 'bitvector'
my @chromosome = $ga->as_array($chromosome)
# @chromosome looks something like that
# ( undef, undef, undef, 1, 0, 1, 1, 1, 0 )
@chromosome = $ga->as_array_def_only($chromosome)
# @chromosome looks something like that
# ( 1, 0, 1, 1, 1, 0 )
$ga->as_string($chromosome)
Return a string representation of the specified chromosome. See
example below:
# -type => 'bitvector'
my $string = $ga->as_string($chromosome);
# $string looks something like that
# 1___0___1___1___1___0
# or
# -type => 'listvector'
$string = $ga->as_string($chromosome);
# $string looks something like that
# element0___element1___element2___element3...
Attention! If variable_length is turned on and is set to level 2, it
is possible to get undef values on the left side of the vector. In
the returned string undef values will be replaced with spaces. If you
don't want to see any spaces, use as_string_def_only instead of
as_string.
$ga->as_string_def_only($chromosome)
Return a string representation of specified chromosome. If
variable_length is turned off, this function is just alias for
as_string. If variable_length is turned on and is set to level 2,
this function will return a string without undef values. See example
below:
# -variable_length => 2, -type => 'bitvector'
my $string = $ga->as_string($chromosome);
# $string looks something like that
# ___ ___ ___1___1___0
$string = $ga->as_string_def_only($chromosome);
# $string looks something like that
# 1___1___0
$ga->as_value($chromosome)
Return the score of the specified chromosome. The value of chromosome
is calculated by the fitness function.
SUPPORT
AI::Genetic::Pro is still under development; however, it is used in
many production environments.
TODO
Examples.
More tests.
More warnings about incorrect parameters.
REPORTING BUGS
When reporting bugs/problems please include as much information as
possible. It may be difficult for me to reproduce the problem as almost
every setup is different.
A small script which yields the problem will probably be of help.
THANKS
Mario Roy for suggestions about efficiency.
Miles Gould for suggestions and some fixes (even in this documentation!
:-).
Alun Jones for fixing memory leaks.
Tod Hagan for reporting a bug (rangevector values truncated to signed
8-bit quantities) and supplying a patch.
Randal L. Schwartz for reporting a bug in this documentation.
Maciej Misiak for reporting problems with combination (and a bug in a
PMX strategy).
LEONID ZAMDBORG for recommending the addition of variable-length
chromosomes as well as supplying relevant code samples, for testing and
at the end reporting some bugs.
Christoph Meissner for reporting a bug.
Alec Chen for reporting some bugs.
AUTHOR
Strzelecki Lukasz <lukasz@strzeleccy.eu>
SEE ALSO
AI::Genetic Algorithm::Evolutionary
COPYRIGHT
Copyright (c) Strzelecki Lukasz. All rights reserved. This program is
free software; you can redistribute it and/or modify it under the same
terms as Perl itself.
lib/AI/Genetic/Pro.pm view on Meta::CPAN
use List::Util qw( sum );
use List::MoreUtils qw( minmax first_index apply );
#use Data::Dumper; $Data::Dumper::Sortkeys = 1;
use Tie::Array::Packed;
use UNIVERSAL::require;
#-----------------------------------------------------------------------
use AI::Genetic::Pro::Array::Type qw( get_package_by_element_size );
use AI::Genetic::Pro::Chromosome;
#-----------------------------------------------------------------------
__PACKAGE__->mk_accessors(qw(
mce
type
population
terminate
chromosomes
crossover
native
parents _parents
history _history
fitness _fitness _fitness_real
cache
mutation _mutator
strategy _strategist
selection _selector
_translations
generation
preserve
variable_length
_fix_range
_package
_length
strict _strict
workers
size
_init
));
#=======================================================================
# Additional modules
use constant STORABLE => 'Storable';
use constant GD => 'GD::Graph::linespoints';
#=======================================================================
my $_Cache = { };
my $_temp_chromosome;
#=======================================================================
sub new {
my ( $class, %args ) = ( shift, @_ );
#-------------------------------------------------------------------
my %opts = map { if(ref $_){$_}else{ /^-?(.*)$/o; $1 }} @_;
my $self = bless \%opts, $class;
#-------------------------------------------------------------------
$AI::Genetic::Pro::Array::Type::Native = 1 if $self->native;
#-------------------------------------------------------------------
croak(q/Type of chromosomes cannot be "combination" if "variable length" feature is active!/)
if $self->type eq q/combination/ and $self->variable_length;
croak(q/You must specify a crossover strategy with -strategy!/)
unless defined ($self->strategy);
croak(q/Type of chromosomes cannot be "combination" if strategy is not one of: OX, PMX!/)
if $self->type eq q/combination/ and ($self->strategy->[0] ne q/OX/ and $self->strategy->[0] ne q/PMX/);
croak(q/Strategy cannot be "/,$self->strategy->[0],q/" if "variable length" feature is active!/ )
if ($self->strategy->[0] eq 'PMX' or $self->strategy->[0] eq 'OX') and $self->variable_length;
#-------------------------------------------------------------------
$self->_set_strict if $self->strict;
#-------------------------------------------------------------------
return $self unless $self->mce;
#-------------------------------------------------------------------
delete $self->{ mce };
'AI::Genetic::Pro::MCE'->use or die q[Cannot raise multicore support: ] . $@;
return AI::Genetic::Pro::MCE->new( $self, \%args );
}
#=======================================================================
sub _Cache { $_Cache; }
#=======================================================================
# INIT #################################################################
#=======================================================================
sub _set_strict {
my ($self) = @_;
# fitness
my $fitness = $self->fitness();
my $replacement = sub {
my @tmp = @{$_[1]};
my $ret = $fitness->(@_);
my @cmp = @{$_[1]};
die qq/Chromosome was modified in a fitness function from "@tmp" to "@{$_[1]}"!\n/ unless compare(\@tmp, \@cmp);
return $ret;
};
$self->fitness($replacement);
}
#=======================================================================
sub _fitness_cached {
my ($self, $chromosome) = @_;
#my $key = md5_hex(${tied(@$chromosome)});
my $key = md5_hex( $self->_package ? md5_hex( ${ tied( @$chromosome ) } ) : join( q[:], @$chromosome ) );
return $_Cache->{$key} if exists $_Cache->{$key};
$_Cache->{$key} = $self->_fitness_real->($self, $chromosome);
return $_Cache->{$key};
}
#=======================================================================
sub _init_cache {
my ($self) = @_;
$self->_fitness_real($self->fitness);
$self->fitness(\&_fitness_cached);
return;
}
#=======================================================================
sub _check_data_ref {
my ($self, $data_org) = @_;
my $data = clone($data_org);
my $ars;
for(0..$#$data){
next if $ars->{$data->[$_]};
$ars->{$data->[$_]} = 1;
unshift @{$data->[$_]}, undef;
}
return $data;
}
#=======================================================================
# we have to find C to (in some cases) incrase value of range
# due to design model
sub _find_fix_range {
my ($self, $data) = @_;
for my $idx (0..$#$data){
if($data->[$idx]->[1] < 1){
my $const = 1 - $data->[$idx]->[1];
push @{$self->_fix_range}, $const;
$data->[$idx]->[1] += $const;
$data->[$idx]->[2] += $const;
}else{ push @{$self->_fix_range}, 0; }
}
return $data;
}
#=======================================================================
sub init {
my ( $self, $data ) = @_;
croak q/You have to pass some data to "init"!/ unless $data;
#-------------------------------------------------------------------
$self->generation(0);
$self->_init( $data );
$self->_fitness( { } );
$self->_fix_range( [ ] );
$self->_history( [ [ ], [ ], [ ] ] );
$self->_init_cache if $self->cache;
#-------------------------------------------------------------------
if($self->type eq q/listvector/){
croak(q/You have to pass array reference if "type" is set to "listvector"/) unless ref $data eq 'ARRAY';
$self->_translations( $self->_check_data_ref($data) );
}elsif($self->type eq q/bitvector/){
croak(q/You have to pass integer if "type" is set to "bitvector"/) if $data !~ /^\d+$/o;
$self->_translations( [ [ 0, 1 ] ] );
$self->_translations->[$_] = $self->_translations->[0] for 1..$data-1;
}elsif($self->type eq q/combination/){
croak(q/You have to pass array reference if "type" is set to "combination"/) unless ref $data eq 'ARRAY';
$self->_translations( [ clone($data) ] );
$self->_translations->[$_] = $self->_translations->[0] for 1..$#$data;
}elsif($self->type eq q/rangevector/){
croak(q/You have to pass array reference if "type" is set to "rangevector"/) unless ref $data eq 'ARRAY';
$self->_translations( $self->_find_fix_range( $self->_check_data_ref($data) ));
}else{
croak(q/You have to specify first "type" of vector!/);
}
my $size = 0;
if($self->type ne q/rangevector/){ for(@{$self->_translations}){ $size = $#$_ if $#$_ > $size; } }
# else{ for(@{$self->_translations}){ $size = $_->[1] if $_->[1] > $size; } }
else{ for(@{$self->_translations}){ $size = $_->[2] if $_->[2] > $size; } } # Provisional patch for rangevector values truncated to signed 8-bit quantities. Thx to Tod Hagan
my $package = get_package_by_element_size($size);
$self->_package($package);
my $length = ref $data ? sub { $#$data; } : sub { $data - 1 };
if($self->variable_length){
$length = ref $data ? sub { 1 + int( rand( $#{ $self->_init } ) ); } : sub { 1 + int( rand( $self->_init - 1) ); };
}
$self->_length( $length );
$self->chromosomes( [ ] );
push @{$self->chromosomes},
AI::Genetic::Pro::Chromosome->new($self->_translations, $self->type, $package, $length->())
for 1..$self->population;
$self->_calculate_fitness_all();
}
#=======================================================================
# SAVE / LOAD ##########################################################
#=======================================================================
sub spew {
#+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
STORABLE->use( qw( store retrieve freeze thaw ) ) or croak(q/You need "/.STORABLE.q/" module to save a state of "/.__PACKAGE__.q/"!/);
$Storable::Deparse = 1;
$Storable::Eval = 1;
#+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
my ( $self ) = @_;
my $clone = {
_selector => undef,
_strategist => undef,
_mutator => undef,
};
$clone->{ chromosomes } = [ map { ${ tied( @$_ ) } } @{ $self->chromosomes } ]
if $self->_package;
foreach my $key(keys %$self){
next if exists $clone->{$key};
$clone->{$key} = $self->{$key};
}
return $clone;
}
#=======================================================================
sub slurp {
my ( $self, $dump ) = @_;
if( my $typ = $self->_package ){
@{ $dump->{ chromosomes } } = map {
my $arr = $typ->make_with_packed( $_ );
bless $arr, q[AI::Genetic::Pro::Chromosome];
} @{ $dump->{ chromosomes } };
}
%$self = %$dump;
return 1;
}
#=======================================================================
sub save {
my ( $self, $file ) = @_;
croak(q/You have to specify file!/) unless defined $file;
store( $self->spew, $file );
}
#=======================================================================
sub load {
#+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
STORABLE->use( qw( store retrieve freeze thaw ) ) or croak(q/You need "/.STORABLE.q/" module to load a state of "/.__PACKAGE__.q/"!/);
$Storable::Deparse = 1;
$Storable::Eval = 1;
#+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
my ($self, $file) = @_;
croak(q/You have to specify file!/) unless defined $file;
my $clone = retrieve($file);
return carp('Incorrect file!') unless $clone;
return $self->slurp( $clone );
}
#=======================================================================
# CHARTS ###############################################################
#=======================================================================
sub chart {
GD->require or croak(q/You need "/.GD.q/" module to draw chart of evolution!/);
my ($self, %params) = (shift, @_);
my $graph = GD()->new(($params{-width} || 640), ($params{-height} || 480));
my $data = $self->getHistory;
if(defined $params{-font}){
$graph->set_title_font ($params{-font}, 12);
$graph->set_x_label_font($params{-font}, 10);
$graph->set_y_label_font($params{-font}, 10);
$graph->set_legend_font ($params{-font}, 8);
}
$graph->set_legend(
$params{legend1} || q/Max value/,
$params{legend2} || q/Mean value/,
$params{legend3} || q/Min value/,
);
$graph->set(
x_label_skip => int(($data->[0]->[-1]*4)/100),
x_labels_vertical => 1,
x_label_position => .5,
y_label_position => .5,
y_long_ticks => 1, # poziome linie
x_ticks => 1, # poziome linie
l_margin => 10,
b_margin => 10,
r_margin => 10,
t_margin => 10,
show_values => (defined $params{-show_values} ? 1 : 0),
values_vertical => 1,
values_format => ($params{-format} || '%.2f'),
zero_axis => 1,
#interlaced => 1,
logo_position => 'BR',
legend_placement => 'RT',
bgclr => 'white',
boxclr => '#FFFFAA',
transparent => 0,
title => ($params{'-title'} || q/Evolution/ ),
x_label => ($params{'-x_label'} || q/Generation/),
y_label => ($params{'-y_label'} || q/Value/ ),
( $params{-logo} && -f $params{-logo} ? ( logo => $params{-logo} ) : ( ) )
);
my $gd = $graph->plot( [ [ 0..$#{$data->[0]} ], @$data ] ) or croak($@);
open(my $fh, '>', $params{-filename}) or croak($@);
binmode $fh;
print $fh $gd->png;
close $fh;
return 1;
}
#=======================================================================
# TRANSLATIONS #########################################################
#=======================================================================
sub as_array_def_only {
my ($self, $chromosome) = @_;
return $self->as_array($chromosome)
if not $self->variable_length or $self->variable_length < 2;
if( $self->type eq q/bitvector/ ){
return $self->as_array($chromosome);
}else{
my $ar = $self->as_array($chromosome);
my $idx = first_index { $_ } @$ar;
my @array = @$ar[$idx..$#$chromosome];
return @array if wantarray;
return \@array;
}
}
#=======================================================================
sub as_array {
my ($self, $chromosome) = @_;
if($self->type eq q/bitvector/){
# This could lead to internal error, bacause of underlaying Tie::Array::Packed
#return @$chromosome if wantarray;
#return $chromosome;
my @chr = @$chromosome;
return @chr if wantarray;
return \@chr;
}elsif($self->type eq q/rangevector/){
my $fix_range = $self->_fix_range;
my $c = -1;
#my @array = map { $c++; warn "WARN: $c | ",scalar @$chromosome,"\n" if not defined $fix_range->[$c]; $_ ? $_ - $fix_range->[$c] : undef } @$chromosome;
my @array = map { $c++; $_ ? $_ - $fix_range->[$c] : undef } @$chromosome;
return @array if wantarray;
return \@array;
}else{
my $cnt = 0;
my @array = map { $self->_translations->[$cnt++]->[$_] } @$chromosome;
return @array if wantarray;
return \@array;
}
}
#=======================================================================
sub as_string_def_only {
my ($self, $chromosome) = @_;
return $self->as_string($chromosome)
if not $self->variable_length or $self->variable_length < 2;
my $array = $self->as_array_def_only($chromosome);
return join(q//, @$array) if $self->type eq q/bitvector/;
return join(q/___/, @$array);
}
#=======================================================================
sub as_string {
return join(q//, @{$_[1]}) if $_[0]->type eq q/bitvector/;
return join(q/___/, map { defined $_ ? $_ : q/ / } $_[0]->as_array($_[1]));
}
#=======================================================================
sub as_value {
my ($self, $chromosome) = @_;
croak(q/You MUST call 'as_value' as method of 'AI::Genetic::Pro' object./)
unless defined $_[0] and ref $_[0] and ( ref $_[0] eq 'AI::Genetic::Pro' or ref $_[0] eq 'AI::Genetic::Pro::MCE');
croak(q/You MUST pass 'AI::Genetic::Pro::Chromosome' object to 'as_value' method./)
unless defined $_[1] and ref $_[1] and ref $_[1] eq 'AI::Genetic::Pro::Chromosome';
return $self->fitness->($self, $chromosome);
}
#=======================================================================
# ALGORITHM ############################################################
#=======================================================================
sub _calculate_fitness_all {
my ($self) = @_;
$self->_fitness( { } );
$self->_fitness->{$_} = $self->fitness()->($self, $self->chromosomes->[$_])
for 0..$#{$self->chromosomes};
# sorting the population is not necessary
# my (@chromosomes, %fitness);
# for my $idx (sort { $self->_fitness->{$a} <=> $self->_fitness->{$b} } keys %{$self->_fitness}){
# push @chromosomes, $self->chromosomes->[$idx];
# $fitness{$#chromosomes} = $self->_fitness->{$idx};
# delete $self->_fitness->{$idx};
# delete $self->chromosomes->[$idx];
# }
#
# $self->_fitness(\%fitness);
# $self->chromosomes(\@chromosomes);
return;
}
#=======================================================================
sub _select_parents {
my ($self) = @_;
unless($self->_selector){
croak "You must specify a selection strategy!"
unless defined $self->selection;
my @tmp = @{$self->selection};
my $selector = q/AI::Genetic::Pro::Selection::/ . shift @tmp;
$selector->require or die $!;
$self->_selector($selector->new(@tmp));
}
$self->_parents($self->_selector->run($self));
return;
}
#=======================================================================
sub _crossover {
my ($self) = @_;
unless($self->_strategist){
my @tmp = @{$self->strategy};
my $strategist = q/AI::Genetic::Pro::Crossover::/ . shift @tmp;
$strategist->require or die $!;
$self->_strategist($strategist->new(@tmp));
}
my $a = $self->_strategist->run($self);
$self->chromosomes( $a );
return;
}
#=======================================================================
sub _mutation {
my ($self) = @_;
unless($self->_mutator){
my $mutator = q/AI::Genetic::Pro::Mutation::/ . ucfirst(lc($self->type));
unless($mutator->require){
$mutator = q/AI::Genetic::Pro::Mutation::Listvector/;
$mutator->require;
}
$self->_mutator($mutator->new);
}
return $self->_mutator->run($self);
}
#=======================================================================
sub _save_history {
my @tmp;
if($_[0]->history){ @tmp = $_[0]->getAvgFitness; }
else { @tmp = (undef, undef, undef); }
push @{$_[0]->_history->[0]}, $tmp[0];
push @{$_[0]->_history->[1]}, $tmp[1];
push @{$_[0]->_history->[2]}, $tmp[2];
return 1;
}
#=======================================================================
sub inject {
my ($self, $candidates) = @_;
for(@$candidates){
push @{$self->chromosomes},
AI::Genetic::Pro::Chromosome->new_from_data($self->_translations, $self->type, $self->_package, $_, $self->_fix_range);
$self->_fitness->{$#{$self->chromosomes}} = $self->fitness()->($self, $self->chromosomes->[-1]);
}
$self->_strict( [ ] );
$self->population( $self->population + scalar( @$candidates ) );
return 1;
}
#=======================================================================
sub _state {
my ( $self ) = @_;
my @res;
if( $self->_package ){
@res = map {
[
${ tied( @{ $self->chromosomes->[ $_ ] } ) },
$self->_fitness->{ $_ },
]
} 0 .. $self->population - 1
}else{
@res = map {
[
$self->chromosomes->[ $_ ],
$self->_fitness->{ $_ },
]
} 0 .. $self->population - 1
}
return \@res;
}
#=======================================================================
sub evolve {
my ($self, $generations) = @_;
# generations must be defined
$generations ||= -1;
if($self->strict and $self->_strict){
for my $idx (0..$#{$self->chromosomes}){
croak(q/Chromosomes was modified outside the 'evolve' function!/) unless $self->chromosomes->[$idx] and $self->_strict->[$idx];
my @tmp0 = @{$self->chromosomes->[$idx]};
my @tmp1 = @{$self->_strict->[$idx]};
croak(qq/Chromosome was modified outside the 'evolve' function from "@tmp0" to "@tmp1"!/) unless compare(\@tmp0, \@tmp1);
}
}
# split into two loops just for speed
unless($self->preserve){
for(my $i = 0; $i != $generations; $i++){
# terminate ----------------------------------------------------
last if $self->terminate and $self->terminate->($self);
# update generation --------------------------------------------
$self->generation($self->generation + 1);
# update history -----------------------------------------------
$self->_save_history;
# selection ----------------------------------------------------
$self->_select_parents();
# crossover ----------------------------------------------------
$self->_crossover();
# mutation -----------------------------------------------------
$self->_mutation();
}
}else{
croak('You cannot preserve more chromosomes than is in population!') if $self->preserve > $self->population;
my @preserved;
for(my $i = 0; $i != $generations; $i++){
# terminate ----------------------------------------------------
last if $self->terminate and $self->terminate->($self);
# update generation --------------------------------------------
$self->generation($self->generation + 1);
# update history -----------------------------------------------
$self->_save_history;
#---------------------------------------------------------------
# preservation of N unique chromosomes
@preserved = map { clone($_) } @{ $self->getFittest_as_arrayref($self->preserve - 1, 1) };
# selection ----------------------------------------------------
$self->_select_parents();
# crossover ----------------------------------------------------
$self->_crossover();
# mutation -----------------------------------------------------
$self->_mutation();
#---------------------------------------------------------------
for(@preserved){
my $idx = int rand @{$self->chromosomes};
$self->chromosomes->[$idx] = $_;
$self->_fitness->{$idx} = $self->fitness()->($self, $_);
}
}
}
if($self->strict){
$self->_strict( [ ] );
push @{$self->_strict}, $_->clone for @{$self->chromosomes};
}
}
#=======================================================================
# ALIASES ##############################################################
#=======================================================================
sub people { $_[0]->chromosomes() }
#=======================================================================
sub getHistory { $_[0]->_history() }
#=======================================================================
sub mutProb { shift->mutation(@_) }
#=======================================================================
sub crossProb { shift->crossover(@_) }
#=======================================================================
sub intType { shift->type() }
#=======================================================================
# STATS ################################################################
#=======================================================================
sub getFittest_as_arrayref {
my ($self, $n, $uniq) = @_;
$n ||= 1;
$self->_calculate_fitness_all() unless scalar %{ $self->_fitness };
my @keys = sort { $self->_fitness->{$a} <=> $self->_fitness->{$b} } 0..$#{$self->chromosomes};
if($uniq){
my %grep;
my $chromosomes = $self->chromosomes;
if( my $pkg = $self->_package ){
my %tmp;
@keys = grep {
my $key = ${ tied( @{ $chromosomes->[ $_ ] } ) };
#my $key = md5_hex( ${ tied( @{ $chromosomes->[ $_ ] } ) } ); # ?
$tmp{ $key } && 0 or $tmp{ $key } = 1;
} @keys;
#@keys = grep {
# my $add_to_list = 0;
# my $key = md5_hex(${tied(@{$chromosomes->[$_]})});
# unless($grep{$key}) {
# $grep{$key} = 1;
# $add_to_list = 1;
# }
# $add_to_list;
# } @keys;
}else{
my %tmp;
@keys = grep {
my $key = md5_hex( join( q[:], @{ $chromosomes->[ $_ ] } ) );
$tmp{ $key } && 0 or $tmp{ $key } = 1;
} @keys;
}
}
$n = scalar @keys if $n > scalar @keys;
return [ reverse @{$self->chromosomes}[ splice @keys, $#keys - $n + 1, $n ] ];
}
#=======================================================================
sub getFittest { return wantarray ? @{ shift->getFittest_as_arrayref(@_) } : shift @{ shift->getFittest_as_arrayref(@_) }; }
#=======================================================================
sub getAvgFitness {
my ($self) = @_;
my @minmax = minmax values %{$self->_fitness};
my $mean = sum(values %{$self->_fitness}) / scalar values %{$self->_fitness};
return $minmax[1], int($mean), $minmax[0];
}
#=======================================================================
1;
__END__
=head1 NAME
AI::Genetic::Pro - Efficient genetic algorithms for professional purpose with support for multiprocessing.
=head1 SYNOPSIS
use AI::Genetic::Pro;
sub fitness {
my ($ga, $chromosome) = @_;
return oct('0b' . $ga->as_string($chromosome));
}
sub terminate {
my ($ga) = @_;
my $result = oct('0b' . $ga->as_string($ga->getFittest));
return $result == 4294967295 ? 1 : 0;
}
my $ga = AI::Genetic::Pro->new(
-fitness => \&fitness, # fitness function
-terminate => \&terminate, # terminate function
-type => 'bitvector', # type of chromosomes
-population => 1000, # population
-crossover => 0.9, # probab. of crossover
-mutation => 0.01, # probab. of mutation
-parents => 2, # number of parents
-selection => [ 'Roulette' ], # selection strategy
-strategy => [ 'Points', 2 ], # crossover strategy
-cache => 0, # cache results
-history => 1, # remember best results
-preserve => 3, # remember the bests
-variable_length => 1, # turn variable length ON
-mce => 1, # optional MCE support
-workers => 3, # number of workers (MCE)
);
# init population of 32-bit vectors
$ga->init(32);
# evolve 10 generations
$ga->evolve(10);
# best score
print "SCORE: ", $ga->as_value($ga->getFittest), ".\n";
# save evolution path as a chart
$ga->chart(-filename => 'evolution.png');
# save state of GA
$ga->save('genetic.sga');
# load state of GA
$ga->load('genetic.sga');
=head1 DESCRIPTION
This module provides efficient implementation of a genetic algorithm for
professional purpose with support for multiprocessing. It was designed to operate as fast as possible
even on very large populations and big individuals/chromosomes. C<AI::Genetic::Pro>
was inspired by C<AI::Genetic>, so it is in most cases compatible
(there are some changes). Additionally C<AI::Genetic::Pro> isn't a pure Perl solution, so it
doesn't have limitations of its ancestor (such as slow-down in the
case of big populations ( >10000 ) or vectors with more than 33 fields).
lib/AI/Genetic/Pro.pm view on Meta::CPAN
=item -mutation
This defines the mutation rate. The fairest results are achieved with mutation
rate ~0.01.
=item -preserve
This defines injection of the bests chromosomes into a next generation. It causes a little slow down, however (very often) much better results are achieved. You can specify, how many chromosomes will be preserved, i.e.
-preserve => 1, # only one chromosome will be preserved
# or
-preserve => 9, # 9 chromosomes will be preserved
# and so on...
Attention! You cannot preserve more chromosomes than exist in your population.
=item -variable_length
This defines whether variable-length chromosomes are turned on (default off)
and a which types of mutation are allowed. See below.
=over 8
=item level 0
Feature is inactive (default). Example:
-variable_length => 0
# chromosomes (i.e. bitvectors)
0 1 0 0 1 1 0 1 1 1 0 1 0 1
0 0 1 1 0 1 1 1 1 0 0 1 1 0
0 1 1 1 0 1 0 0 1 1 0 1 1 1
0 1 0 0 1 1 0 1 1 1 1 0 1 0
# ...and so on
=item level 1
Feature is active, but chromosomes can varies B<only on the right side>, Example:
-variable_length => 1
# chromosomes (i.e. bitvectors)
0 1 0 0 1 1 0 1 1 1
0 0 1 1 0 1 1 1 1
0 1 1 1 0 1 0 0 1 1 0 1 1 1
0 1 0 0 1 1 0 1 1 1
# ...and so on
=item level 2
Feature is active and chromosomes can varies B<on the left side and on
the right side>; unwanted values/genes on the left side are replaced with C<undef>, ie.
-variable_length => 2
# chromosomes (i.e. bitvectors)
x x x 0 1 1 0 1 1 1
x x x x 0 1 1 1 1
x 1 1 1 0 1 0 0 1 1 0 1 1 1
0 1 0 0 1 1 0 1 1 1
# where 'x' means 'undef'
# ...and so on
In this situation returned chromosomes in an array context ($ga-E<gt>as_array($chromosome))
can have B<undef> values on the left side (only). In a scalar context each
undefined value is replaced with a single space. If You don't want to see
any C<undef> or space, just use C<as_array_def_only> and C<as_string_def_only>
instead of C<as_array> and C<as_string>.
=back
=item -parents
This defines how many parents should be used in a crossover.
=item -selection
This defines how individuals/chromosomes are selected to crossover. It expects an array reference listed below:
-selection => [ $type, @params ]
where type is one of:
=over 8
=item B<RouletteBasic>
Each individual/chromosome can be selected with probability proportional to its fitness.
=item B<Roulette>
lib/AI/Genetic/Pro.pm view on Meta::CPAN
=item C<-selection =E<gt> [ 'RouletteDistribution', 'normal', $av, $sd ]>
Normal distribution, where C<$av> is average (default: size of population /2) and $C<$sd> is standard deviation (default: size of population).
=item C<-selection =E<gt> [ 'RouletteDistribution', 'beta', $aa, $bb ]>
I<Beta> distribution. The density of the beta is:
X^($aa - 1) * (1 - X)^($bb - 1) / B($aa , $bb) for 0 < X < 1.
C<$aa> and C<$bb> are set by default to number of parents.
B<Argument restrictions:> Both $aa and $bb must not be less than 1.0E-37.
=item C<-selection =E<gt> [ 'RouletteDistribution', 'binomial' ]>
Binomial distribution. No additional parameters are needed.
=item C<-selection =E<gt> [ 'RouletteDistribution', 'chi_square', $df ]>
lib/AI/Genetic/Pro.pm view on Meta::CPAN
Standard uniform distribution. No additional parameters are needed.
=item C<-selection =E<gt> [ 'Distribution', 'normal', $av, $sd ]>
Normal distribution, where C<$av> is average (default: size of population /2) and $C<$sd> is standard deviation (default: size of population).
=item C<-selection =E<gt> [ 'Distribution', 'beta', $aa, $bb ]>
I<Beta> distribution. The density of the beta is:
X^($aa - 1) * (1 - X)^($bb - 1) / B($aa , $bb) for 0 < X < 1.
C<$aa> and C<$bb> are set by default to number of parents.
B<Argument restrictions:> Both $aa and $bb must not be less than 1.0E-37.
=item C<-selection =E<gt> [ 'Distribution', 'binomial' ]>
Binomial distribution. No additional parameters are needed.
=item C<-selection =E<gt> [ 'Distribution', 'chi_square', $df ]>
lib/AI/Genetic/Pro.pm view on Meta::CPAN
=back
=back
=item -strategy
This defines the astrategy of crossover operation. It expects an array
reference listed below:
-strategy => [ $type, @params ]
where type is one of:
=over 4
=item PointsSimple
Simple crossover in one or many points. The best chromosomes/individuals are
selected for the new generation. For example:
-strategy => [ 'PointsSimple', $n ]
where C<$n> is the number of points for crossing.
=item PointsBasic
Crossover in one or many points. In basic crossover selected parents are
crossed and one (randomly-chosen) child is moved to the new generation. For
example:
-strategy => [ 'PointsBasic', $n ]
where C<$n> is the number of points for crossing.
=item Points
Crossover in one or many points. In normal crossover selected parents are crossed and the best child is moved to the new generation. For example:
-strategy => [ 'Points', $n ]
where C<$n> is number of points for crossing.
=item PointsAdvenced
Crossover in one or many points. After crossover the best
chromosomes/individuals from all parents and chidren are selected for the new
generation. For example:
-strategy => [ 'PointsAdvanced', $n ]
where C<$n> is the number of points for crossing.
=item Distribution
In I<distribution> crossover parents are crossed in points selected with the
specified distribution. See below.
=over 8
lib/AI/Genetic/Pro.pm view on Meta::CPAN
Standard uniform distribution. No additional parameters are needed.
=item C<-strategy =E<gt> [ 'Distribution', 'normal', $av, $sd ]>
Normal distribution, where C<$av> is average (default: number of parents/2) and C<$sd> is standard deviation (default: number of parents).
=item C<-strategy =E<gt> [ 'Distribution', 'beta', $aa, $bb ]>
I<Beta> distribution. The density of the beta is:
X^($aa - 1) * (1 - X)^($bb - 1) / B($aa , $bb) for 0 < X < 1.
C<$aa> and C<$bb> are set by default to the number of parents.
B<Argument restrictions:> Both $aa and $bb must not be less than 1.0E-37.
=item C<-strategy =E<gt> [ 'Distribution', 'binomial' ]>
Binomial distribution. No additional parameters are needed.
=item C<-strategy =E<gt> [ 'Distribution', 'chi_square', $df ]>
lib/AI/Genetic/Pro.pm view on Meta::CPAN
This defines if the check for modifying chromosomes in a user-defined fitness
function is active. Directly modifying chromosomes is not allowed and it is
a highway to big trouble. This mode should be used only for testing, because it is B<slow>.
=back
=item I<$ga>-E<gt>B<inject>($chromosomes)
Inject new, user defined, chromosomes into the current population. See example below:
# example for bitvector
my $chromosomes = [
[ 1, 1, 0, 1, 0, 1 ],
[ 0, 0, 0, 1, 0, 1 ],
[ 0, 1, 0, 1, 0, 0 ],
...
];
# inject
$ga->inject($chromosomes);
If You want to delete some chromosomes from population, just C<splice> them:
my @remove = qw(1 2 3 9 12);
for my $idx (sort { $b <=> $a } @remove){
splice @{$ga->chromosomes}, $idx, 1;
}
=item I<$ga>-E<gt>B<population>($population)
Set/get size of the population. This defines the size of the population, i.e. how many chromosomes to simultaneously exist at each generation.
=item I<$ga>-E<gt>B<indType>()
Get type of individuals/chromosomes. Currently supported types are:
=over 4
lib/AI/Genetic/Pro.pm view on Meta::CPAN
=item C<combination>
Chromosomes will be unique lists of specified values. This is used for example
in the I<Traveling Salesman Problem>. See the documentation of the C<new>
method.
=back
In example:
my $type = $ga->type();
=item I<$ga>-E<gt>B<type>()
Alias for C<indType>.
=item I<$ga>-E<gt>B<crossProb>()
This method is used to query and set the crossover rate.
=item I<$ga>-E<gt>B<crossover>()
lib/AI/Genetic/Pro.pm view on Meta::CPAN
=item I<$ga>-E<gt>B<init>($args)
This method initializes the population with random individuals/chromosomes. It MUST be called before any call to C<evolve()>. It expects one argument, which depends on the type of individuals/chromosomes:
=over 4
=item B<bitvector>
For bitvectors, the argument is simply the length of the bitvector.
$ga->init(10);
This initializes a population where each individual/chromosome has 10 genes.
=item B<listvector>
For listvectors, the argument is an anonymous list of lists. The number of sub-lists is equal to the number of genes of each individual/chromosome. Each sub-list defines the possible string values that the corresponding gene can assume.
$ga->init([
[qw/red blue green/],
[qw/big medium small/],
[qw/very_fat fat fit thin very_thin/],
]);
This initializes a population where each individual/chromosome has 3 genes and each gene can assume one of the given values.
=item B<rangevector>
For rangevectors, the argument is an anonymous list of lists. The number of sub-lists is equal to the number of genes of each individual/chromosome. Each sub-list defines the minimum and maximum integer values that the corresponding gene can assume.
$ga->init([
[1, 5],
[0, 20],
[4, 9],
]);
This initializes a population where each individual/chromosome has 3 genes and each gene can assume an integer within the corresponding range.
=item B<combination>
For combination, the argument is an anonymous list of possible values of gene.
$ga->init( [ 'a', 'b', 'c' ] );
This initializes a population where each chromosome has 3 genes and each gene
is a unique combination of 'a', 'b' and 'c'. For example genes looks something
like that:
[ 'a', 'b', 'c' ] # gene 1
[ 'c', 'a', 'b' ] # gene 2
[ 'b', 'c', 'a' ] # gene 3
# ...and so on...
=back
=item I<$ga>-E<gt>B<evolve>($n)
This method causes the GA to evolve the population for the specified number of
generations. If its argument is 0 or C<undef> GA will evolve the population to
infinity unless a C<terminate> function is specified.
=item I<$ga>-E<gt>B<getHistory>()
Get history of the evolution. It is in a format listed below:
[
# gen0 gen1 gen2 ... # generations
[ max0, max1, max2, ... ], # max values
[ mean, mean1, mean2, ... ], # mean values
[ min0, min1, min2, ... ], # min values
]
=item I<$ga>-E<gt>B<getAvgFitness>()
Get I<max>, I<mean> and I<min> score of the current generation. In example:
my ($max, $mean, $min) = $ga->getAvgFitness();
=item I<$ga>-E<gt>B<getFittest>($n, $unique)
This function returns a list of the fittest chromosomes from the current
population. You can specify how many chromosomes should be returned and if
the returned chromosomes should be unique. See example below.
# only one - the best
my ($best) = $ga->getFittest;
# or 5 bests chromosomes, NOT unique
my @bests = $ga->getFittest(5);
# or 7 bests and UNIQUE chromosomes
my @bests = $ga->getFittest(7, 1);
If you want to get a large number of chromosomes, try to use the
C<getFittest_as_arrayref> function instead (for efficiency).
=item I<$ga>-E<gt>B<getFittest_as_arrayref>($n, $unique)
This function is very similar to C<getFittest>, but it returns a reference
to an array instead of a list.
=item I<$ga>-E<gt>B<generation>()
lib/AI/Genetic/Pro.pm view on Meta::CPAN
=item -font
Path to font (in *.ttf format) to be used (default: none).
=item -logo
Path to logo (png/jpg image) to embed in a chart (default: none).
=item For example:
$ga->chart(-width => 480, height => 320, -filename => 'chart.png');
=back
=item I<$ga>-E<gt>B<save>($file)
Save the current state of the genetic algorithm to the specified file.
=item I<$ga>-E<gt>B<load>($file)
Load a state of the genetic algorithm from the specified file.
lib/AI/Genetic/Pro.pm view on Meta::CPAN
=item I<$ga>-E<gt>B<as_array_def_only>($chromosome)
In list context return an array representing the specified chromosome.
In scalar context return an reference to an array representing the specified
chromosome. If I<variable_length> is turned off, this function is just an
alias for C<as_array>. If I<variable_length> is turned on and is set to
level 2, this function will return only C<not undef> values from chromosome.
See example below:
# -variable_length => 2, -type => 'bitvector'
my @chromosome = $ga->as_array($chromosome)
# @chromosome looks something like that
# ( undef, undef, undef, 1, 0, 1, 1, 1, 0 )
@chromosome = $ga->as_array_def_only($chromosome)
# @chromosome looks something like that
# ( 1, 0, 1, 1, 1, 0 )
=item I<$ga>-E<gt>B<as_string>($chromosome)
Return a string representation of the specified chromosome. See example below:
# -type => 'bitvector'
my $string = $ga->as_string($chromosome);
# $string looks something like that
# 1___0___1___1___1___0
# or
# -type => 'listvector'
$string = $ga->as_string($chromosome);
# $string looks something like that
# element0___element1___element2___element3...
Attention! If I<variable_length> is turned on and is set to level 2, it is
possible to get C<undef> values on the left side of the vector. In the returned
string C<undef> values will be replaced with B<spaces>. If you don't want
to see any I<spaces>, use C<as_string_def_only> instead of C<as_string>.
=item I<$ga>-E<gt>B<as_string_def_only>($chromosome)
Return a string representation of specified chromosome. If I<variable_length>
is turned off, this function is just alias for C<as_string>. If I<variable_length>
is turned on and is set to level 2, this function will return a string without
C<undef> values. See example below:
# -variable_length => 2, -type => 'bitvector'
my $string = $ga->as_string($chromosome);
# $string looks something like that
# ___ ___ ___1___1___0
$string = $ga->as_string_def_only($chromosome);
# $string looks something like that
# 1___1___0
=item I<$ga>-E<gt>B<as_value>($chromosome)
Return the score of the specified chromosome. The value of I<chromosome> is
calculated by the fitness function.
=back
=head1 SUPPORT
lib/AI/Genetic/Pro/Array/Type.pm view on Meta::CPAN
package AI::Genetic::Pro::Array::Type;
$AI::Genetic::Pro::Array::Type::VERSION = '1.009';
use warnings;
use strict;
use Exporter::Lite;
use Tie::Array::Packed;
#=======================================================================
our @EXPORT_OK = qw(
get_package_by_element_size
get_array_ref_by_element_size
);
#-----------------------------------------------------------------------
our $Native = 0;
#=======================================================================
sub get_package_by_element_size {
return if $Native;
my $size = shift;
my $type = #$size < 32 ? undef : # Pure Perl array
#$size < 32 ? 'AI::Genetic::Pro::Array::Tied' : # Pure Perl array
$size < 128 ? 'Tie::Array::Packed::Char' : # 8 bits
$size < 256 ? 'Tie::Array::Packed::UnsignedChar' : # 8 bits
$size < 65_537 ? 'Tie::Array::Packed::ShortNative' : # 16 bits
$size < 131_073 ? 'Tie::Array::Packed::UnsignedShortNative' : # 16 bits
$size < 2_147_483_648 ? 'Tie::Array::Packed::Integer' : # 32 bits
$size < 4_294_967_297 ? 'Tie::Array::Packed::UnsignedInteger' : # 32 bits; MAX
undef;
return unless $type;
return $type;
}
#=======================================================================
sub get_array_ref_by_element_size {
my $package = get_package_by_element_size(shift);
my @array;
tie @array, $package if $package;
return \@array;
}
#=======================================================================
1;
lib/AI/Genetic/Pro/Chromosome.pm view on Meta::CPAN
package AI::Genetic::Pro::Chromosome;
$AI::Genetic::Pro::Chromosome::VERSION = '1.009';
use warnings;
use strict;
use List::Util qw(shuffle first);
use List::MoreUtils qw(first_index);
use Tie::Array::Packed;
#use Math::Random qw(random_uniform_integer);
#=======================================================================
sub new {
my ($class, $data, $type, $package, $length) = @_;
my @genes;
tie @genes, $package if $package;
if($type eq q/bitvector/){
#@genes = random_uniform_integer(scalar @$data, 0, 1); # this is fastest, but uses more memory
@genes = map { rand > 0.5 ? 1 : 0 } 0..$length; # this is faster
#@genes = split(q//, unpack("b*", rand 99999), $#$data + 1); # slow
}elsif($type eq q/combination/){
#@genes = shuffle 0..$#{$data->[0]};
@genes = shuffle 0..$length;
}elsif($type eq q/rangevector/){
@genes = map { $_->[1] + int rand($_->[2] - $_->[1] + 1) } @$data[0..$length];
}else{
@genes = map { 1 + int(rand( $#{ $data->[$_] })) } 0..$length;
}
return bless \@genes, $class;
}
#=======================================================================
sub new_from_data {
my ($class, $data, $type, $package, $values, $fix_range) = @_;
die qq/\nToo many elements in the injected chromosome of type "$type": @$values\n/ if $#$values > $#$data;
my @genes;
tie @genes, $package if $package;
if($type eq q/bitvector/){
die qq/\nInproper value in the injected chromosome of type "$type": @$values\n/
if first { not defined $_ or ($_ != 0 and $_ != 1) } @$values;
@genes = @$values;
}elsif($type eq q/combination/){
die qq/\nToo few elements in the injected chromosome of type "$type": @$values\n/
if $#$values != $#{$data->[0]};
for my $idx(0..$#$values){
my $id = first_index { $_ eq $values->[$idx] } @{$data->[0]}; # pomijamy poczatkowy undef
die qq/\nInproper element in the injected chromosome of type "$type": @$values\n/ if $id == -1;
push @genes, $id;
}
}elsif($type eq q/rangevector/){
for my $idx(0..$#$values){
if(defined $values->[$idx]){
my $min = $data->[$idx]->[1] - $fix_range->[$idx];
my $max = $data->[$idx]->[2] - $fix_range->[$idx];
die qq/\nValue out of scope in the injected chromosome of type "$type": @$values\n/
if $values->[$idx] > $max or $values->[$idx] < $min;
push @genes, $values->[$idx] + $fix_range->[$idx];
}else{ push @genes, 0; }
}
}else{
for my $idx(0..$#$values){
my $id = first_index {
not defined $values->[$idx] and not defined $_ or
defined $_ and defined $values->[$idx] and $_ eq $values->[$idx]
} @{$data->[$idx]}; # pomijamy poczatkowy undef
die qq/\nInproper element in the injected chromosome of type "$type": @$values\n/ if $id == -1;
push @genes, $id;
}
}
return bless \@genes, $class;
}
#=======================================================================
sub clone
{
my ( $self ) = @_;
my $cln;
if( my $obj = tied( @$self ) ){
$cln = $obj->make_clone;
}else{
@$cln = @$self;
}
return bless( $cln );
#my $genes = tied(@{$self})->make_clone;
#return bless($genes);
}
#=======================================================================
1;
lib/AI/Genetic/Pro/Crossover/Distribution.pm view on Meta::CPAN
package AI::Genetic::Pro::Crossover::Distribution;
$AI::Genetic::Pro::Crossover::Distribution::VERSION = '1.009';
use warnings;
use strict;
#use Data::Dumper; $Data::Dumper::Sortkeys = 1;
use Math::Random qw(
random_uniform_integer
random_normal
random_beta
random_binomial
random_chi_square
random_exponential
random_poisson
);
use List::MoreUtils qw(first_index);
#=======================================================================
sub new {
my ($class, $type, @params) = @_;
bless {
type => $type,
params => \@params,
}, $class;
}
#=======================================================================
sub run {
my ($self, $ga) = @_;
my ($chromosomes, $parents, $crossover) = ($ga->chromosomes, $ga->_parents, $ga->crossover);
my ($fitness, $_fitness) = ($ga->fitness, $ga->_fitness);
my $high = scalar @{$chromosomes->[0]};
my @children;
#-------------------------------------------------------------------
while(my $elders = shift @$parents){
my @elders = unpack 'I*', $elders;
unless(scalar @elders){
$_fitness->{scalar(@children)} = $fitness->($ga, $chromosomes->[$elders[0]]);
push @children, $chromosomes->[$elders[0]];
next;
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
my $len = scalar @elders;
my @seq;
if($self->{type} eq q/uniform/){
@seq = random_uniform_integer($high, 0, $#elders);
}elsif($self->{type} eq q/normal/){
my $av = defined $self->{params}->[0] ? $self->{params}->[0] : $len/2;
my $sd = defined $self->{params}->[1] ? $self->{params}->[1] : $len;
@seq = map { $_ % $len } random_normal($high, $av, $sd);
}elsif($self->{type} eq q/beta/){
my $aa = defined $self->{params}->[0] ? $self->{params}->[0] : $len;
my $bb = defined $self->{params}->[1] ? $self->{params}->[1] : $len;
@seq = map { int($_ * $len) } random_beta($high, $aa, $bb);
}elsif($self->{type} eq q/binomial/){
@seq = random_binomial($high, $#elders, rand);
}elsif($self->{type} eq q/chi_square/){
my $df = defined $self->{params}->[0] ? $self->{params}->[0] : $len;
@seq = map { $_ % $len } random_chi_square($high, $df);
}elsif($self->{type} eq q/exponential/){
my $av = defined $self->{params}->[0] ? $self->{params}->[0] : $len/2;
@seq = map { $_ % $len } random_exponential($high, $av);
}elsif($self->{type} eq q/poisson/){
my $mu = defined $self->{params}->[0] ? $self->{params}->[0] : $len/2;
@seq = map { $_ % $len } random_poisson($high, $mu) ;
}else{
die qq/Unknown distribution "$self->{type}" in "crossover"!\n/;
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
my ($min, $max) = (0, $#{$chromosomes->[0]} - 1);
if($ga->variable_length){
for my $el(@elders){
my $idx = first_index { $_ } @{$chromosomes->[$el]};
$min = $idx if $idx > $min;
$max = $#{$chromosomes->[$el]} if $#{$chromosomes->[$el]} < $max;
}
}
$elders[0] = $chromosome->[$elders[0]]->clone;
for(0..$#seq){
next if not $seq[$_] or $_ < $min or $_ > $max;
$elders[0]->[$_] = $chromosomes->[$elders[$seq[$_]]]->[$_];
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
push @children, $elders[ 0 ];
}
#-------------------------------------------------------------------
return \@children;
}
#=======================================================================
1;
lib/AI/Genetic/Pro/Crossover/OX.pm view on Meta::CPAN
package AI::Genetic::Pro::Crossover::OX;
$AI::Genetic::Pro::Crossover::OX::VERSION = '1.009';
use warnings;
use strict;
use List::MoreUtils qw(first_index);
#use Data::Dumper; $Data::Dumper::Sortkeys = 1;
#=======================================================================
sub new { bless \$_[0], $_[0]; }
#=======================================================================
sub save_fitness {
my ($self, $ga, $idx) = @_;
$ga->_fitness->{$idx} = $ga->fitness->($ga, $ga->chromosomes->[$idx]);
return $ga->chromosomes->[$idx];
}
#=======================================================================
sub run {
my ($self, $ga) = @_;
my ($chromosomes, $parents, $crossover) = ($ga->chromosomes, $ga->_parents, $ga->crossover);
my ($fitness, $_fitness) = ($ga->fitness, $ga->_fitness);
my @children;
#-------------------------------------------------------------------
while(my $elders = shift @$parents){
my @elders = unpack 'I*', $elders;
unless(scalar @elders){
push @children, $chromosomes->[$elders[0]];
next;
}
my @points = sort { $a <=> $b } map { 1 + int(rand $#{$chromosomes->[0]}) } 0..1;
@elders = sort {
my @av = @{$a}[$points[0]..$points[1]];
my @bv = @{$b}[$points[0]..$points[1]];
for my $e(@av){
splice(@$b, (first_index { $_ == $e } @$b), 1);
}
splice @$b, $points[0], 0, @av;
for my $e(@bv){
splice(@$a, (first_index { $_ == $e } @$a), 1);
}
splice @$a, $points[0], 0, @bv;
0;
} map {
$chromosomes->[$_]->clone;
} @elders;
my %elders = map { $_ => $fitness->($ga, $elders[$_]) } 0..$#elders;
my $max = (sort { $elders{$a} <=> $elders{$b} } keys %elders)[-1];
$_fitness->{scalar(@children)} = $elders{$max};
push @children, $elders[$max];
}
#-------------------------------------------------------------------
return \@children;
}
#=======================================================================
1;
lib/AI/Genetic/Pro/Crossover/PMX.pm view on Meta::CPAN
package AI::Genetic::Pro::Crossover::PMX;
$AI::Genetic::Pro::Crossover::PMX::VERSION = '1.009';
use warnings;
use strict;
use List::MoreUtils qw(indexes);
#use Data::Dumper; $Data::Dumper::Sortkeys = 1;
#=======================================================================
sub new { bless \$_[0], $_[0]; }
#=======================================================================
sub dup {
my ($ar) = @_;
my %seen;
my @dup = grep { if($seen{$_}){ 1 }else{ $seen{$_} = 1; 0} } @$ar;
return \@dup if @dup;
return;
}
#=======================================================================
sub run {
my ($self, $ga) = @_;
my ($chromosomes, $parents, $crossover) = ($ga->chromosomes, $ga->_parents, $ga->crossover);
my ($fitness, $_fitness) = ($ga->fitness, $ga->_fitness);
my @children;
#-------------------------------------------------------------------
while(my $elders = shift @$parents){
my @elders = unpack 'I*', $elders;
unless(scalar @elders){
push @children, $chromosomes->[$elders[0]];
next;
}
my @points = sort { $a <=> $b } map { 1 + int(rand $#{$chromosomes->[0]}) } 0..1;
@elders = sort {
my @av = @{$a}[$points[0]..$points[1]-1];
my @bv = splice @$b, $points[0], $points[1] - $points[0], @av;
splice @$a, $points[0], $points[1] - $points[0], @bv;
my %av; @av{@av} = @bv;
my %bv; @bv{@bv} = @av;
while(my $dup = dup($a)){
foreach my $val (@$dup){
my ($ind) = grep { $_ < $points[0] or $_ >= $points[1] } indexes { $_ == $val } @$a;
$a->[$ind] = $bv{$val};
}
}
while(my $dup = dup($b)){
foreach my $val (@$dup){
my ($ind) = grep { $_ < $points[0] or $_ >= $points[1] } indexes { $_ == $val } @$b;
$b->[$ind] = $av{$val};
}
}
0;
} map {
$chromosomes->[$_]->clone
} @elders;
my %elders = map { $_ => $fitness->($ga, $elders[$_]) } 0..$#elders;
my $max = (sort { $elders{$a} <=> $elders{$b} } keys %elders)[-1];
$_fitness->{scalar(@children)} = $elders{$max};
push @children, $elders[$max];
}
#-------------------------------------------------------------------
return \@children;
}
#=======================================================================
1;
lib/AI/Genetic/Pro/Crossover/Points.pm view on Meta::CPAN
package AI::Genetic::Pro::Crossover::Points;
$AI::Genetic::Pro::Crossover::Points::VERSION = '1.009';
use warnings;
use strict;
use List::MoreUtils qw(first_index);
#use Data::Dumper; $Data::Dumper::Sortkeys = 1;
#=======================================================================
sub new { bless { points => $_[1] ? $_[1] : 1 }, $_[0]; }
#=======================================================================
sub run {
my ($self, $ga) = @_;
my ($chromosomes, $parents, $crossover) = ($ga->chromosomes, $ga->_parents, $ga->crossover);
my ($fitness, $_fitness) = ($ga->fitness, $ga->_fitness);
my @children;
#-------------------------------------------------------------------
while(my $elders = shift @$parents){
my @elders = unpack 'I*', $elders;
unless(scalar @elders){
$_fitness->{scalar(@children)} = $fitness->($ga, $chromosomes->[$elders[0]]);
push @children, $chromosomes->[$elders[0]];
next;
}
my ($min, $max) = (0, $#{$chromosomes->[0]});
if($ga->variable_length){
for my $el(@elders){
my $idx = first_index { $_ } @{$chromosomes->[$el]};
$min = $idx if $idx > $min;
$max = $#{$chromosomes->[$el]} if $#{$chromosomes->[$el]} < $max;
}
}
my @points;
if($min < $max and $max - $min > 2){
my $range = $max - $min;
@points = map { $min + int(rand $range) } 1..$self->{points};
}
@elders = map { $chromosomes->[$_]->clone } @elders;
for my $pt(@points){
@elders = sort {
splice @$b, 0, $pt, splice( @$a, 0, $pt, @$b[0..$pt-1] );
0;
} @elders;
}
my %elders = map { $_ => $fitness->($ga, $elders[$_]) } 0..$#elders;
my $maximum = (sort { $elders{$a} <=> $elders{$b} } keys %elders)[-1];
$_fitness->{scalar(@children)} = $elders{$maximum};
push @children, $elders[$maximum];
}
#-------------------------------------------------------------------
return \@children;
}
#=======================================================================
1;
lib/AI/Genetic/Pro/Crossover/PointsAdvanced.pm view on Meta::CPAN
$AI::Genetic::Pro::Crossover::PointsAdvanced::VERSION = '1.009';
use warnings;
use strict;
use List::MoreUtils qw(first_index);
#use Data::Dumper; $Data::Dumper::Sortkeys = 1;
#use AI::Genetic::Pro::Array::PackTemplate;
#=======================================================================
sub new { bless { points => $_[1] ? $_[1] : 1 }, $_[0]; }
#=======================================================================
sub run {
my ($self, $ga) = @_;
my ($chromosomes, $parents, $crossover) = ($ga->chromosomes, $ga->_parents, $ga->crossover);
my ($fitness, $_fitness) = ($ga->fitness, $ga->_fitness);
#-------------------------------------------------------------------
while(my $elders = shift @$parents){
my @elders = unpack 'I*', $elders;
unless(scalar @elders){
push @$chromosomes, $chromosomes->[$elders[0]];
next;
}
my ($min, $max) = (0, $#{$chromosomes->[0]} - 1);
if($ga->variable_length){
for my $el(@elders){
my $idx = first_index { $_ } @{$chromosomes->[$el]};
$min = $idx if $idx > $min;
$max = $#{$chromosomes->[$el]} if $#{$chromosomes->[$el]} < $max;
}
}
my @points;
if($min < $max and $max - $min > 2){
my $range = $max - $min;
@points = map { $min + int(rand $range) } 1..$self->{points};
}
@elders = map { $chromosomes->[$_]->clone } @elders;
for my $pt(@points){
@elders = sort {
splice @$b, 0, $pt, splice( @$a, 0, $pt, @$b[0..$pt-1] );
0;
} @elders;
}
push @$chromosomes, @elders;
}
#-------------------------------------------------------------------
# wybieranie potomkow ze zbioru starych i nowych osobnikow
@$chromosomes = sort { $fitness->($ga, $a) <=> $fitness->($ga, $b) } @$chromosomes;
splice @$chromosomes, 0, scalar(@$chromosomes) - $ga->population;
%$_fitness = map { $_ => $fitness->($ga, $chromosomes->[$_]) } 0..$#$chromosomes;
#-------------------------------------------------------------------
return $chromosomes;
}
#=======================================================================
1;
lib/AI/Genetic/Pro/Crossover/PointsBasic.pm view on Meta::CPAN
package AI::Genetic::Pro::Crossover::PointsBasic;
$AI::Genetic::Pro::Crossover::PointsBasic::VERSION = '1.009';
use warnings;
use strict;
use List::MoreUtils qw(first_index);
#use Data::Dumper; $Data::Dumper::Sortkeys = 1;
#=======================================================================
sub new { bless { points => $_[1] ? $_[1] : 1 }, $_[0]; }
#=======================================================================
sub run {
my ($self, $ga) = @_;
my ($chromosomes, $parents, $crossover) = ($ga->chromosomes, $ga->_parents, $ga->crossover);
my ($fitness, $_fitness) = ($ga->fitness, $ga->_fitness);
my @children;
#-------------------------------------------------------------------
while(my $elders = shift @$parents){
my @elders = unpack 'I*', $elders;
unless(scalar @elders){
$_fitness->{scalar(@children)} = $fitness->($ga, $chromosomes->[$elders[0]]);
push @children, $chromosomes->[$elders[0]];
next;
}
my ($min, $max) = (0, $#{$chromosomes->[0]} - 1);
if($ga->variable_length){
for my $el(@elders){
my $idx = first_index { $_ } @{$chromosomes->[$el]};
$min = $idx if $idx > $min;
$max = $#{$chromosomes->[$el]} if $#{$chromosomes->[$el]} < $max;
}
}
my @points;
if($min < $max and $max - $min > 2){
my $range = $max - $min;
@points = map { $min + int(rand $range) } 1..$self->{points};
}
@elders = map { $chromosomes->[$_]->clone } @elders;
for my $pt(@points){
@elders = sort {
splice @$b, 0, $pt, splice( @$a, 0, $pt, @$b[0..$pt-1] );
0;
} @elders;
}
my $idx = int rand @elders;
$_fitness->{scalar(@children)} = $fitness->($ga, $elders[$idx]);
push @children, $elders[ $idx ];
}
#-------------------------------------------------------------------
return \@children;
}
#=======================================================================
1;
lib/AI/Genetic/Pro/Crossover/PointsSimple.pm view on Meta::CPAN
package AI::Genetic::Pro::Crossover::PointsSimple;
$AI::Genetic::Pro::Crossover::PointsSimple::VERSION = '1.009';
use warnings;
use strict;
use List::MoreUtils qw(first_index);
#use Data::Dumper; $Data::Dumper::Sortkeys = 1;
#=======================================================================
sub new { bless { points => $_[1] ? $_[1] : 1 }, $_[0]; }
#=======================================================================
sub run {
my ($self, $ga) = @_;
my ($chromosomes, $parents, $crossover) = ($ga->chromosomes, $ga->_parents, $ga->crossover);
my ($fitness, $_fitness) = ($ga->fitness, $ga->_fitness);
my @children;
#-------------------------------------------------------------------
while(my $elders = shift @$parents){
my @elders = unpack 'I*', $elders;
unless(scalar @elders){
push @children, $chromosomes->[$elders[0]];
next;
}
my ($min, $max) = (0, $#{$chromosomes->[0]} - 1);
if($ga->variable_length){
for my $el(@elders){
my $idx = first_index { $_ } @{$chromosomes->[$el]};
$min = $idx if $idx > $min;
$max = $#{$chromosomes->[$el]} if $#{$chromosomes->[$el]} < $max;
}
}
my @points;
if($min < $max and $max - $min > 2){
my $range = $max - $min;
@points = map { $min + int(rand $range) } 1..$self->{points};
}
@elders = map { $chromosomes->[$_]->clone } @elders;
for my $pt(@points){
@elders = sort {
splice @$b, 0, $pt, splice( @$a, 0, $pt, @$b[0..$pt-1] );
0;
} @elders;
}
push @children, @elders;
}
#-------------------------------------------------------------------
# wybieranie potomkow ze zbioru nowych osobnikow
@children = sort { $fitness->($ga, $a) <=> $fitness->($ga, $b) } @children;
splice @children, 0, scalar(@children) - scalar(@$chromosomes);
%$_fitness = map { $_ => $fitness->($ga, $children[$_]) } 0..$#children;
#-------------------------------------------------------------------
return \@children;
}
#=======================================================================
1;
lib/AI/Genetic/Pro/MCE.pm view on Meta::CPAN
use List::Util qw( shuffle );
use MCE( Sereal => 0 );
#use MCE::Loop;
use MCE::Map;
use MCE::Util;
#-----------------------------------------------------------------------
$Storable::Deparse = 1;
$Storable::Eval = 1;
#-----------------------------------------------------------------------
__PACKAGE__->mk_accessors( qw(
_pop
_tpl
));
#=======================================================================
sub new {
my ( $cls, $obj, $tpl ) = @_;
my $self = bless $obj, $cls;
#-------------------------------------------------------------------
$self->_init_mce;
$self->_init_pop;
#-------------------------------------------------------------------
$AI::Genetic::Pro::Array::Type::Native = 1 if $self->native;
#-------------------------------------------------------------------
delete $tpl->{ $_ } for qw( -history -mce -population -workers );
$self->_tpl( $tpl );
#-------------------------------------------------------------------
return $self;
}
#=======================================================================
sub _init_pop {
my ( $self ) = @_;
my $pop = int( $self->population / $self->workers );
my $rst = $self->population % $self->workers;
my @pop = ( $pop ) x $self->workers;
$pop[ 0 ] += $rst;
$self->_pop( \@pop );
}
#=======================================================================
sub _calculate_fitness_all {
my ($self) = @_;
# Faster version. Thanks to Mario Roy :-)
my %fit = mce_map_s {
$_ => $self->fitness()->( $self, $self->chromosomes->[ $_ ] )
} 0, $#{ $self->chromosomes };
# The old one
#my %fit = mce_map {
# $_ => $self->fitness()->( $self, $self->chromosomes->[ $_ ] )
# } 0 .. $#{ $self->chromosomes };
$self->_fitness( \%fit );
return;
}
#=======================================================================
sub _init_mce {
my ( $self ) = @_;
#-------------------------------------------------------------------
$self->workers( MCE::Util::get_ncpu() ) unless $self->workers;
#-------------------------------------------------------------------
MCE::Map->init(
chunk_size => 1, # Thanks Roy :-)
#chunk_size => q[auto], # The old one
max_workers => $self->workers,
posix_exit => 1, # Thanks Roy :-)
);
#-------------------------------------------------------------------
return;
}
#=======================================================================
sub init {
my ( $self, $val ) = @_;
#-------------------------------------------------------------------
my $pop = $self->population;
$self->population( 1 );
$self->SUPER::init( $val );
$self->population( $pop );
#-------------------------------------------------------------------
my $one = shift @{ $self->chromosomes };
my $tpl = $self->_tpl;
my @lst = mce_map {
my $arg = clone( $tpl );
$arg->{ -population } = $_;
my $gal = AI::Genetic::Pro->new( %$arg );
$gal->init( $val );
@{ $gal->_state };
} @{ $self->_pop };
#-------------------------------------------------------------------
return $self->_adopt( \@lst );
}
#=======================================================================
sub _adopt {
my ( $self, $lst ) = @_;
if( my $typ = $self->_package ){
for my $idx ( 0 .. $#$lst ){
$lst->[ $idx ]->[ 0 ] = $typ->make_with_packed( $lst->[ $idx ]->[ 0 ] );
bless $lst->[ $idx ]->[ 0 ], q[AI::Genetic::Pro::Chromosome];
}
}
my ( @chr, %fit, @rhc, %tif );
for my $sth ( @$lst ){
push @chr, $sth->[ 0 ];
$fit{ $#chr } = $sth->[ 1 ];
}
#@$lst = ( );
my @idx = shuffle 0 .. $#chr;
for my $i ( @idx ){
push @rhc, $chr[ $i ];
$tif{ $#rhc } = $fit{ $i };
}
$self->_fitness ( \%tif );
$self->chromosomes( \@rhc );
return;
}
#=======================================================================
sub _chunks {
my ( $self ) = @_;
my $cnt = 0;
my @chk;
for my $idx ( 0 .. $#{ $self->_pop } ){
my $pos = 0;
my %tmp = map { $pos++ => $self->_fitness->{ $_ } } $cnt .. $cnt + $self->_pop->[ $idx ] -1 ;
my @tmp = splice @{ $self->chromosomes }, 0, $self->_pop->[ $idx ];
$cnt += @tmp;
if( $self->_package ){
push @chk, [
[ map { ${ tied( @$_ ) } } @tmp ],
\%tmp,
];
}else{
push @chk, [
\@tmp,
\%tmp,
];
}
}
return \@chk;
}
#=======================================================================
sub evolve {
my ( $self, $generations ) = @_;
$generations ||= -1;
for(my $i = 0; $i != $generations; $i++){
# terminate ----------------------------------------------------
last if $self->terminate and $self->terminate->( $self );
# update generation --------------------------------------------
$self->generation($self->generation + 1);
# update history -----------------------------------------------
$self->_save_history;
my $tpl = $self->_tpl;
my @lst = mce_map {
#- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
my $ary = $_;
#- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
my $arg = clone( $tpl );
$arg->{ -population } = 1;
my $gal = AI::Genetic::Pro->new( %$arg );
$gal->init( 1 );
#- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
if( my $typ = $self->_package ){
for my $idx ( 0 .. $#{ $ary->[ 0 ] } ){
$ary->[ 0 ][ $idx ] = $typ->make_with_packed( $ary->[ 0 ][ $idx ] );
bless $ary->[ 0 ][ $idx ], q[AI::Genetic::Pro::Chromosome];
}
}
#- - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
$gal->population ( scalar( @{ $ary->[ 0 ] } ) );
$gal->chromosomes( $ary->[ 0 ] );
$gal->_fitness ( $ary->[ 1 ] );
$gal->strict ( 0 );
#- - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
$gal->evolve ( 1 );
#- - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
@{ $gal->_state };
} $self->_chunks;
$self->_adopt( \@lst );
}
return;
}
#=======================================================================
1;
lib/AI/Genetic/Pro/Mutation/Bitvector.pm view on Meta::CPAN
package AI::Genetic::Pro::Mutation::Bitvector;
$AI::Genetic::Pro::Mutation::Bitvector::VERSION = '1.009';
use warnings;
use strict;
#use Data::Dumper; $Data::Dumper::Sortkeys = 1;
#=======================================================================
sub new { bless \$_[0], $_[0]; }
#=======================================================================
sub run {
my ($self, $ga) = @_;
# this is declared here just for speed
my $mutation = $ga->mutation;
my $chromosomes = $ga->chromosomes;
my $_translations = $ga->_translations;
my ($fitness, $_fitness) = ($ga->fitness, $ga->_fitness);
# main loop
for my $idx (0..$#$chromosomes){
next if rand() >= $mutation;
if($ga->variable_length){
my $rand = rand();
if($rand < 0.16 and $#{$chromosomes->[$idx]} > 1){
pop @{$chromosomes->[$idx]};
}elsif($rand < 0.32 and $#{$chromosomes->[$idx]} > 1){
shift @{$chromosomes->[$idx]};
}elsif($rand < 0.48 and $#{$chromosomes->[$idx]} < $#$_translations){
push @{$chromosomes->[$idx]}, rand > 0.5 ? 0 : 1;
}elsif($rand < 0.64 and $#{$chromosomes->[$idx]} < $#$_translations){
unshift @{$chromosomes->[$idx]}, rand > 0.5 ? 0 : 1;
}elsif($rand < 0.8){
##tied(@{$chromosomes->[$idx]})->reverse;
#if( my $obj = tied( @{ $chromosomes->[ $idx ] } ) ){
# $obj->reverse;
#}else{
# @{ $chromosomes->[ $idx ] } = reverse @{ $chromosomes->[ $idx ] };
#}
#@{ $chromosomes->[ $idx ] } = reverse @{ $chromosomes->[ $idx ] };
}else{
my $id = int rand @{$chromosomes->[$idx]};
$chromosomes->[$idx]->[$id] = $chromosomes->[$idx]->[$id] ? 0 : 1;
}
}else{
my $id = int rand @{$chromosomes->[$idx]};
$chromosomes->[$idx]->[$id] = $chromosomes->[$idx]->[$id] ? 0 : 1;
}
# we need to change fitness
$_fitness->{$idx} = $fitness->($ga, $chromosomes->[$idx]);
}
return 1;
}
#=======================================================================
# too slow; mutation is too dangerous in this solution
sub run0 {
my ($self, $ga) = @_;
my $mutation = $ga->mutation; # this is declared here just for speed
foreach my $chromosome (@{$ga->{chromosomes}}){
if(rand() < $mutation){ tied(@$chromosome)->reverse; }
else{
for(0..$#$chromosome){
next if rand > $mutation;
$chromosome->[$_] = $chromosome->[$_] ? 0 : 1;
}
}
}
return 1;
}
#=======================================================================
1;
lib/AI/Genetic/Pro/Mutation/Combination.pm view on Meta::CPAN
package AI::Genetic::Pro::Mutation::Combination;
$AI::Genetic::Pro::Mutation::Combination::VERSION = '1.009';
use warnings;
use strict;
use List::MoreUtils qw(first_index);
#use Data::Dumper; $Data::Dumper::Sortkeys = 1;
#=======================================================================
sub new { bless \$_[0], $_[0]; }
#=======================================================================
sub run {
my ($self, $ga) = @_;
# this is declared here just for speed
my $mutation = $ga->mutation;
my $chromosomes = $ga->chromosomes;
my $_translations = $ga->_translations;
my ($fitness, $_fitness) = ($ga->fitness, $ga->_fitness);
my $inv = $mutation / 2;
# main loop
for my $idx (0..$#$chromosomes){
my $rand = rand;
if($rand < $inv) { tied(@{$chromosomes->[$idx]})->reverse; }
elsif($rand < $mutation){
my $el = int rand @{$chromosomes->[$idx]};
my $new = int rand @{$_translations->[0]};
next if $new == $chromosomes->[$idx]->[$el];
my $id = first_index { $_ == $new } @{$chromosomes->[$idx]};
$chromosomes->[$idx]->[$id] = $chromosomes->[$idx]->[$el] if defined $id and $id != -1;
$chromosomes->[$idx]->[$el] = $new;
}
# we need to change fitness
$_fitness->{$idx} = $fitness->($ga, $chromosomes->[$idx]);
}
return 1;
}
#=======================================================================
1;
lib/AI/Genetic/Pro/Mutation/Listvector.pm view on Meta::CPAN
package AI::Genetic::Pro::Mutation::Listvector;
$AI::Genetic::Pro::Mutation::Listvector::VERSION = '1.009';
use warnings;
use strict;
use List::MoreUtils qw(first_index);
#use Data::Dumper; $Data::Dumper::Sortkeys = 1;
#=======================================================================
sub new { bless \$_[0], $_[0]; }
#=======================================================================
sub run {
my ($self, $ga) = @_;
# this is declared here just for speed
my $mutation = $ga->mutation;
my $chromosomes = $ga->chromosomes;
my $_translations = $ga->_translations;
my ($fitness, $_fitness) = ($ga->fitness, $ga->_fitness);
# main loop
for my $idx (0..$#$chromosomes){
next if rand() >= $mutation;
if($ga->variable_length){
my $rand = rand();
my $min = first_index { $_ } @{$chromosomes->[$idx]};
my $range = $#{$chromosomes->[$idx]} - $min + 1;
if($rand < 0.4 and $range > 2){
if($rand < 0.2 and $ga->variable_length > 1){ $chromosomes->[$idx]->[$min] = 0; }
else{ pop @{$chromosomes->[$idx]}; }
}elsif($rand < 0.8 and $range < $#$_translations){
if($rand < 0.6 and $ga->variable_length > 1 and not $chromosomes->[$idx]->[0]){
$chromosomes->[$idx]->[ $min - 1 ] = 1 + int rand $#{$_translations->[ $min - 1 ]};
}elsif(exists $_translations->[scalar @{$chromosomes->[$idx]}]){
push @{$chromosomes->[$idx]}, 1 + int rand $#{$_translations->[scalar @{$chromosomes->[$idx]}]};
}
}else{
my $id = $min + int rand($range - 1);
$chromosomes->[$idx]->[$id] = 1 + int rand $#{$_translations->[$id]};
}
}else{
my $id = int rand @{$chromosomes->[$idx]};
$chromosomes->[$idx]->[$id] = 1 + int rand $#{$_translations->[$id]};
}
# we need to change fitness
$_fitness->{$idx} = $fitness->($ga, $chromosomes->[$idx]);
}
return 1;
}
#=======================================================================
1;
lib/AI/Genetic/Pro/Mutation/Rangevector.pm view on Meta::CPAN
$AI::Genetic::Pro::Mutation::Rangevector::VERSION = '1.009';
use warnings;
use strict;
use List::MoreUtils qw(first_index);
use Math::Random qw(random_uniform_integer);
#use Data::Dumper; $Data::Dumper::Sortkeys = 1;
#=======================================================================
sub new { bless \$_[0], $_[0]; }
#=======================================================================
sub run {
my ($self, $ga) = @_;
# this is declared here just for speed
my $mutation = $ga->mutation;
my $chromosomes = $ga->chromosomes;
my $_translations = $ga->_translations;
my ($fitness, $_fitness) = ($ga->fitness, $ga->_fitness);
# main loop
for my $idx (0..$#$chromosomes){
next if rand() >= $mutation;
if($ga->variable_length){
my $rand = rand();
my $min = first_index { $_ } @{$chromosomes->[$idx]};
my $range = $#{$chromosomes->[$idx]} - $min + 1;
if($rand < 0.4 and $range > 2){
if($rand < 0.2 and $ga->variable_length > 1){ $chromosomes->[$idx]->[$min] = 0; }
else{ pop @{$chromosomes->[$idx]}; }
}elsif($rand < 0.8 and $range < scalar @{$_translations}){
if($rand < 0.6 and $ga->variable_length > 1 and not $chromosomes->[$idx]->[0]){
$chromosomes->[$idx]->[ $min - 1 ] = random_uniform_integer(1, @{$_translations->[ $min - 1 ]}[1..2]);
}elsif(exists $_translations->[scalar @{$chromosomes->[$idx]}]){
push @{$chromosomes->[$idx]}, random_uniform_integer(1, @{$_translations->[scalar @{$chromosomes->[$idx]}]}[1..2]);
}
}else{
my $id = $min + int rand($range - 1);
$chromosomes->[$idx]->[$id] = random_uniform_integer(1, @{$_translations->[$id]}[1..2]);
}
}else{
my $id = int rand @{$chromosomes->[$idx]};
$chromosomes->[$idx]->[$id] = random_uniform_integer(1, @{$_translations->[$id]}[1..2]);
}
# we need to change fitness
$_fitness->{$idx} = $fitness->($ga, $chromosomes->[$idx]);
}
return 1;
}
#=======================================================================
sub run0 {
my ($self, $ga) = @_;
# this is declared here just for speed
my $mutation = $ga->mutation;
# main loop
foreach my $chromosome (@{$ga->{chromosomes}}){
next if rand() <= $mutation;
if($ga->variable_length){
my $rand = rand();
if($rand < 0.33 and $#$chromosome > 1){
pop @$chromosome;
}elsif($rand < 0.66 and $#$chromosome < $#{$ga->_translations}){
push @$chromosome, random_uniform_integer(1, @{$ga->_translations->[scalar @$chromosome]});
}else{
my $idx = int rand @$chromosome;
$chromosome->[$idx] = random_uniform_integer(1, @{$ga->_translations->[$idx]});
}
}else{
my $idx = int rand @$chromosome;
$chromosome->[$idx] = random_uniform_integer(1, @{$ga->_translations->[$idx]});
}
}
return 1;
}
#=======================================================================
1;
lib/AI/Genetic/Pro/Selection/Distribution.pm view on Meta::CPAN
package AI::Genetic::Pro::Selection::Distribution;
$AI::Genetic::Pro::Selection::Distribution::VERSION = '1.009';
use warnings;
use strict;
#use Data::Dumper; $Data::Dumper::Sortkeys = 1;
#use AI::Genetic::Pro::Array::PackTemplate;
use Math::Random qw(
random_uniform_integer
random_normal
random_beta
random_binomial
random_chi_square
random_exponential
random_poisson
);
use Carp 'croak';
#=======================================================================
sub new {
my ($class, $type, @params) = @_;
bless {
type => $type,
params => \@params,
}, $class;
}
#=======================================================================
sub run {
my ($self, $ga) = @_;
my ($fitness, $chromosomes) = ($ga->_fitness, $ga->chromosomes);
croak "You must set a number of parents to use the Distribution strategy"
unless defined($ga->parents);
my $parents = $ga->parents;
my @parents;
my $high = scalar @$chromosomes;
#-------------------------------------------------------------------
if($self->{type} eq q/uniform/){
push @parents,
pack 'I*', random_uniform_integer($parents, 0, $#$chromosomes)
for 0..$#$chromosomes;
}elsif($self->{type} eq q/normal/){
my $av = defined $self->{params}->[0] ? $self->{params}->[0] : $#$chromosomes/2;
my $sd = defined $self->{params}->[1] ? $self->{params}->[1] : $#$chromosomes;
push @parents,
pack 'I*', map { int $_ % $high } random_normal($parents, $av, $sd)
for 0..$#$chromosomes;
}elsif($self->{type} eq q/beta/){
my $aa = defined $self->{params}->[0] ? $self->{params}->[0] : $parents;
my $bb = defined $self->{params}->[1] ? $self->{params}->[1] : $parents;
push @parents,
pack 'I*', map { int($_ * $high) } random_beta($parents, $aa, $bb)
for 0..$#$chromosomes;
}elsif($self->{type} eq q/binomial/){
push @parents,
pack 'I*', random_binomial($parents, $#$chromosomes, rand)
for 0..$#$chromosomes;
}elsif($self->{type} eq q/chi_square/){
my $df = defined $self->{params}->[0] ? $self->{params}->[0] : $#$chromosomes;
push @parents,
pack 'I*', map { int $_ % $high } random_chi_square($parents, $df)
for 0..$#$chromosomes;
}elsif($self->{type} eq q/exponential/){
my $av = defined $self->{params}->[0] ? $self->{params}->[0] : $#$chromosomes/2;
push @parents,
pack 'I*', map { int $_ % $high } random_exponential($parents, $av)
for 0..$#$chromosomes;
}elsif($self->{type} eq q/poisson/){
my $mu = defined $self->{params}->[0] ? $self->{params}->[0] : $#$chromosomes/2;
push @parents,
pack 'I*', map { int $_ % $high } random_poisson($parents, $mu)
for 0..$#$chromosomes;
}else{
die qq/Unknown distribution "$self->{type}" in "selection"!\n/;
}
#-------------------------------------------------------------------
return \@parents;
}
#=======================================================================
1;
lib/AI/Genetic/Pro/Selection/Roulette.pm view on Meta::CPAN
use strict;
#use Data::Dumper; $Data::Dumper::Sortkeys = 1;
use List::Util qw(sum min);
use List::MoreUtils qw(first_index);
use Carp 'croak';
#=======================================================================
sub new { bless \$_[0], $_[0]; }
#=======================================================================
sub run {
my ($self, $ga) = @_;
my ($fitness) = ($ga->_fitness);
my (@parents, @elders);
#-------------------------------------------------------------------
my $count = $#{$ga->chromosomes};
my $const = min values %$fitness;
$const = $const < 0 ? abs($const) : 0;
my $total = sum( map { $_ < 0 ? $_ + $const : $_ } values %$fitness);
$total ||= 1;
# elders
for my $idx (0..$count){
push @elders, $idx for 1..int((($fitness->{$idx} + $const) / $total) * $count);
}
if((my $add = $count - scalar @elders) > 0){
my $idx = $elders[rand @elders];
push @elders, int rand($count) for 0..$add;
}
croak "You must set a crossover probability to use the Roulette strategy"
unless defined($ga->crossover);
croak "You must set a number of parents to use the Roulette strategy"
unless defined($ga->parents);
# parents
for(0..$count){
if(rand > $ga->crossover){
push @parents, pack 'I*', $elders[ rand @elders ]
}else{
my @group;
push @group, $elders[ rand @elders ] for 1..$ga->parents;
push @parents, pack 'I*', @group;
}
}
#-------------------------------------------------------------------
return \@parents;
}
#=======================================================================
1;
lib/AI/Genetic/Pro/Selection/RouletteBasic.pm view on Meta::CPAN
use warnings;
use strict;
use List::Util qw(min);
#use Data::Dumper; $Data::Dumper::Sortkeys = 1;
use List::MoreUtils qw(first_index);
use Carp 'croak';
#=======================================================================
sub new { bless \$_[0], $_[0]; }
#=======================================================================
sub run {
my ($self, $ga) = @_;
my ($fitness, $chromosomes) = ($ga->_fitness, $ga->chromosomes);
croak "You must set a number of parents to use the RouletteBasic strategy"
unless defined($ga->parents);
my $parents = $ga->parents;
my (@parents, @wheel);
my $const = min values %$fitness;
$const = $const < 0 ? abs($const) : 0;
my $total = 0;
#-------------------------------------------------------------------
foreach my $key (keys %$fitness){
$total += $fitness->{$key} + $const;
push @wheel, [ $key, $total ];
}
for(0..$#$chromosomes){
my @group;
for(1..$parents){
my $rand = rand($total);
my $idx = first_index { $_->[1] > $rand } @wheel;
if($idx == 0){ $idx = 1 }
elsif($idx == -1 ) { $idx = scalar @wheel; }
push @group, $wheel[$idx-1]->[0];
}
push @parents, pack 'I*', @group;
}
#-------------------------------------------------------------------
return \@parents;
}
#=======================================================================
1;
lib/AI/Genetic/Pro/Selection/RouletteDistribution.pm view on Meta::CPAN
package AI::Genetic::Pro::Selection::RouletteDistribution;
$AI::Genetic::Pro::Selection::RouletteDistribution::VERSION = '1.009';
use warnings;
use strict;
use List::Util qw(min);
use List::MoreUtils qw(first_index);
#use Data::Dumper; $Data::Dumper::Sortkeys = 1;
#use AI::Genetic::Pro::Array::PackTemplate;
use Math::Random qw(
random_uniform
random_normal
random_beta
random_binomial
random_chi_square
random_exponential
random_poisson
);
use Carp 'croak';
#=======================================================================
sub new {
my ($class, $type, @params) = @_;
bless {
type => $type,
params => \@params,
}, $class;
}
#=======================================================================
sub roulette {
my ($total, $wheel) = @_;
my $rand = rand($total);
my $idx = first_index { $_->[1] > $rand } @$wheel;
if($idx == 0){ $idx = 1 }
elsif($idx == -1 ) { $idx = scalar @$wheel; }
return $wheel->[$idx-1]->[0];
}
#=======================================================================
sub run {
my ($self, $ga) = @_;
my ($fitness, $chromosomes) = ($ga->_fitness, $ga->chromosomes);
croak "You must set a number of parents for the RouletteDistribution strategy"
unless defined($ga->parents);
my $parents = $ga->parents;
my $high = scalar @$chromosomes;
my (@parents, @wheel);
my $const = min values %$fitness;
$const = $const < 0 ? abs($const) : 0;
my $total = 0;
#-------------------------------------------------------------------
foreach my $key (keys %$fitness){
$total += $fitness->{$key} + $const;
push @wheel, [ $key, $total ];
}
#-------------------------------------------------------------------
if($self->{type} eq q/uniform/){
push @parents,
pack 'I*',
map { roulette($total, \@wheel) }
random_uniform($parents, 0, $total)
for 0..$#$chromosomes;
}elsif($self->{type} eq q/normal/){
my $av = defined $self->{params}->[0] ? $self->{params}->[0] : $#$chromosomes/2;
my $sd = defined $self->{params}->[1] ? $self->{params}->[1] : $#$chromosomes;
push @parents,
pack 'I*',
map { roulette($total, \@wheel) }
map { int $_ % $high } random_normal($parents, $av, $sd)
for 0..$#$chromosomes;
}elsif($self->{type} eq q/beta/){
my $aa = defined $self->{params}->[0] ? $self->{params}->[0] : $parents;
my $bb = defined $self->{params}->[1] ? $self->{params}->[1] : $parents;
push @parents,
pack 'I*',
map { roulette($total, \@wheel) }
map { int($_ * $high) } random_beta($parents, $aa, $bb)
for 0..$#$chromosomes;
}elsif($self->{type} eq q/binomial/){
push @parents,
pack 'I*',
map { roulette($total, \@wheel) }
random_binomial($parents, $#$chromosomes, rand)
for 0..$#$chromosomes;
}elsif($self->{type} eq q/chi_square/){
my $df = defined $self->{params}->[0] ? $self->{params}->[0] : $#$chromosomes;
push @parents,
pack 'I*',
map { roulette($total, \@wheel) }
map { int $_ % $high } random_chi_square($parents, $df)
for 0..$#$chromosomes;
}elsif($self->{type} eq q/exponential/){
my $av = defined $self->{params}->[0] ? $self->{params}->[0] : $#$chromosomes/2;
push @parents,
pack 'I*',
map { roulette($total, \@wheel) }
map { int $_ % $high } random_exponential($parents, $av)
for 0..$#$chromosomes;
}elsif($self->{type} eq q/poisson/){
my $mu = defined $self->{params}->[0] ? $self->{params}->[0] : $#$chromosomes/2;
push @parents,
pack 'I*',
map { roulette($total, \@wheel) }
map { int $_ % $high } random_poisson($parents, $mu)
for 0..$#$chromosomes;
}else{
die qq/Unknown distribution "$self->{type}" in "selection"!\n/;
}
#-------------------------------------------------------------------
return \@parents;
}
#=======================================================================
1;
t/01_inject.t view on Meta::CPAN
use Struct::Compare;
use AI::Genetic::Pro;
use constant BITS => 32;
my @Win;
push @Win, 1 for 1..BITS;
my $Win = sum( \@Win );
sub sum {
my ($ar) = @_;
my $counter = 0;
for(0..$#$ar){
$counter += $ar->[$_] if $ar->[$_];
}
return $counter;
}
sub fitness {
my ($ga, $chromosome) = @_;
return sum(scalar $ga->as_array($chromosome));
}
sub terminate {
my ($ga) = @_;
return 1 if $Win == $ga->as_value($ga->getFittest);
return;
}
my $ga = AI::Genetic::Pro->new(
-fitness => \&fitness, # fitness function
-terminate => \&terminate, # terminate function
-type => 'bitvector', # type of chromosomes
-population => 100, # population
-crossover => 0.9, # probab. of crossover
-mutation => 0.05, # probab. of mutation
-parents => 2, # number of parents
-selection => [ 'Roulette' ], # selection strategy
-strategy => [ 'Points', 2 ], # crossover strategy
-cache => 0, # cache results
-history => 0, # remember best results
-preserve => 0, # remember the bests
-variable_length => 0, # turn variable length OFF
);
# init population of 32-bit vectors
$ga->init(BITS);
my $population = [ ];
for my $chromosome(@{$ga->chromosomes}){
push @$population, $chromosome->clone;
}
my @data;
for(0..BITS){
my @chromosome;
push @chromosome, rand() < 0.5 ? 1 : 0 for 1..BITS;
push @data, \@chromosome;
}
push @$population, @data;
$ga->inject(\@data);
my $OK = 1;
for(0..$#$population){
my @tmp0 = @{$population->[$_]};
my @tmp1 = @{$ga->chromosomes->[$_]};
unless(compare(\@tmp0, \@tmp1)){
$OK = 0;
last;
}
}
ok($OK);
t/02_cache.t view on Meta::CPAN
use FindBin qw($Bin);
use lib $Bin;
use Test::More qw(no_plan);
use Time::HiRes;
use AI::Genetic::Pro;
use constant BITS => 32;
sub sum {
my ($ar) = @_;
my $counter = 0;
for(0..$#$ar){
$counter += $ar->[$_] if $ar->[$_];
}
return $counter;
}
sub fitness {
my ($ga, $chromosome) = @_;
return sum(scalar $ga->as_array($chromosome));
}
my $ga = AI::Genetic::Pro->new(
-fitness => \&fitness, # fitness function
-terminate => sub { return; }, # terminate function
-type => 'bitvector', # type of chromosomes
-population => 10, # population
-crossover => 0.9, # probab. of crossover
-mutation => 0.05, # probab. of mutation
-parents => 2, # number of parents
-selection => [ 'Roulette' ], # selection strategy
-strategy => [ 'Points', 2 ], # crossover strategy
-cache => 0, # cache results
-history => 0, # remember best results
-preserve => 0, # remember the bests
-variable_length => 0, # turn variable length OFF
);
# init population of 32-bit vectors
$ga->init(BITS);
$ga->chromosomes( [ ] );
$ga->inject( [ [ qw( 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1) ] ] );
my $start = [Time::HiRes::gettimeofday()];
$ga->as_value($ga->chromosomes->[0]) for 0..10000;
my $time0 =Time::HiRes::tv_interval($start);
$ga = AI::Genetic::Pro->new(
-fitness => \&fitness, # fitness function
-terminate => sub { return; }, # terminate function
-type => 'bitvector', # type of chromosomes
-population => 10, # population
-crossover => 0.9, # probab. of crossover
-mutation => 0.05, # probab. of mutation
-parents => 2, # number of parents
-selection => [ 'Roulette' ], # selection strategy
-strategy => [ 'Points', 2 ], # crossover strategy
-cache => 1, # cache results
-history => 0, # remember best results
-preserve => 0, # remember the bests
-variable_length => 0, # turn variable length OFF
);
# init population of 32-bit vectors
$ga->init(BITS);
$ga->chromosomes( [ ] );
$ga->inject( [ [ qw( 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1) ] ] );
$start = [Time::HiRes::gettimeofday()];
$ga->as_value($ga->chromosomes->[0]) for 0..10000;
my $time1 =Time::HiRes::tv_interval($start);
t/03_bitvectors_constant_length.t view on Meta::CPAN
use Test::More qw(no_plan);
use AI::Genetic::Pro;
use constant BITS => 32;
my @Win;
push @Win, 1 for 1..BITS;
my $Win = sum( \@Win );
sub sum {
my ($ar) = @_;
my $counter = 0;
for(0..$#$ar){
$counter += $ar->[$_] if $ar->[$_];
}
return $counter;
}
sub fitness {
my ($ga, $chromosome) = @_;
return sum(scalar $ga->as_array($chromosome));
}
sub terminate {
my ($ga) = @_;
return 1 if $Win == $ga->as_value($ga->getFittest);
return;
}
my $ga = AI::Genetic::Pro->new(
-fitness => \&fitness, # fitness function
-terminate => \&terminate, # terminate function
-type => 'bitvector', # type of chromosomes
-population => 100, # population
-crossover => 0.9, # probab. of crossover
-mutation => 0.05, # probab. of mutation
-parents => 2, # number of parents
-selection => [ 'Roulette' ], # selection strategy
-strategy => [ 'Points', 2 ], # crossover strategy
-cache => 1, # cache results
-history => 0, # remember best results
-preserve => 0, # remember the bests
-variable_length => 0, # turn variable length OFF
);
# init population of 32-bit vectors
$ga->init(BITS);
my @helper = (
[ qw( 0 0 0 0 0 0 0 0 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 ) ],
[ qw( 1 1 1 1 1 1 1 1 0 0 0 0 0 0 0 0 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 ) ],
[ qw( 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 0 0 0 0 0 0 0 0 1 1 1 1 1 1 1 1 ) ],
[ qw( 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 0 0 0 0 0 0 0 0 ) ],
[ qw( 0 0 0 0 0 0 0 0 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 ) ],
[ qw( 1 1 1 1 1 1 1 1 0 0 0 0 0 0 0 0 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 ) ],
[ qw( 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 0 0 0 0 0 0 0 0 1 1 1 1 1 1 1 1 ) ],
[ qw( 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 0 0 0 0 0 0 0 0 ) ],
[ qw( 0 0 0 0 0 0 0 0 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 ) ],
[ qw( 1 1 1 1 1 1 1 1 0 0 0 0 0 0 0 0 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 ) ],
[ qw( 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 0 0 0 0 0 0 0 0 1 1 1 1 1 1 1 1 ) ],
[ qw( 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 0 0 0 0 0 0 0 0 ) ],
);
$ga->inject(\@helper);
# evolve 1000 generations
$ga->evolve(1000);
ok($Win == $ga->as_value($ga->getFittest));
t/04_bitvectors_variable_length_I.t view on Meta::CPAN
use Test::More qw(no_plan);
use AI::Genetic::Pro;
use constant BITS => 32;
my @Win;
push @Win, 1 for 0..BITS-1;
my $Win = sum( \@Win );
sub sum {
my ($ar) = @_;
my $counter = 0;
for(0..$#$ar){
$counter += $ar->[$_] if $ar->[$_];
}
return $counter;
}
sub fitness {
my ($ga, $chromosome) = @_;
return sum(scalar $ga->as_array($chromosome));
}
sub terminate {
my ($ga) = @_;
return 1 if $Win == $ga->as_value($ga->getFittest);
return;
}
my $ga = AI::Genetic::Pro->new(
-fitness => \&fitness, # fitness function
-terminate => \&terminate, # terminate function
-type => 'bitvector', # type of chromosomes
-population => 100, # population
-crossover => 0.9, # probab. of crossover
-mutation => 0.05, # probab. of mutation
-parents => 2, # number of parents
-selection => [ 'Roulette' ], # selection strategy
-strategy => [ 'Points', 2 ], # crossover strategy
-cache => 1, # cache results
-history => 0, # remember best results
-preserve => 0, # remember the bests
-variable_length => 1, # turn variable length OFF
);
# init population of 32-bit vectors
$ga->init(BITS);
my @helper = (
[ qw( 0 0 0 0 0 0 0 0 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 ) ],
[ qw( 1 1 1 1 1 1 1 1 0 0 0 0 0 0 0 0 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 ) ],
[ qw( 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 0 0 0 0 0 0 0 0 1 1 1 1 1 1 1 1 ) ],
[ qw( 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 0 0 0 0 0 0 0 0 ) ],
[ qw( 0 0 0 0 0 0 0 0 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 ) ],
[ qw( 1 1 1 1 1 1 1 1 0 0 0 0 0 0 0 0 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 ) ],
[ qw( 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 0 0 0 0 0 0 0 0 1 1 1 1 1 1 1 1 ) ],
[ qw( 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 0 0 0 0 0 0 0 0 ) ],
[ qw( 0 0 0 0 0 0 0 0 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 ) ],
[ qw( 1 1 1 1 1 1 1 1 0 0 0 0 0 0 0 0 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 ) ],
[ qw( 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 0 0 0 0 0 0 0 0 1 1 1 1 1 1 1 1 ) ],
[ qw( 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 0 0 0 0 0 0 0 0 ) ],
);
$ga->inject(\@helper);
# evolve 1000 generations
$ga->evolve(1000);
ok($Win == $ga->as_value($ga->getFittest));
t/05_bitvectors_variable_length_II.t view on Meta::CPAN
use Test::More qw(no_plan);
use AI::Genetic::Pro;
use constant BITS => 32;
my @Win;
push @Win, 1 for 0..BITS-1;
my $Win = sum( \@Win );
sub sum {
my ($ar) = @_;
my $counter = 0;
for(0..$#$ar){
$counter += $ar->[$_] if $ar->[$_];
}
return $counter;
}
sub fitness {
my ($ga, $chromosome) = @_;
return sum(scalar $ga->as_array($chromosome));
}
sub terminate {
my ($ga) = @_;
return 1 if $Win == $ga->as_value($ga->getFittest);
return;
}
my $ga = AI::Genetic::Pro->new(
-fitness => \&fitness, # fitness function
-terminate => \&terminate, # terminate function
-type => 'bitvector', # type of chromosomes
-population => 100, # population
-crossover => 0.9, # probab. of crossover
-mutation => 0.05, # probab. of mutation
-parents => 2, # number of parents
-selection => [ 'Roulette' ], # selection strategy
-strategy => [ 'Points', 2 ], # crossover strategy
-cache => 1, # cache results
-history => 0, # remember best results
-preserve => 0, # remember the bests
-variable_length => 2, # turn variable length OFF
);
# init population of 32-bit vectors
$ga->init(BITS);
my @helper = (
[ qw( 0 0 0 0 0 0 0 0 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 ) ],
[ qw( 1 1 1 1 1 1 1 1 0 0 0 0 0 0 0 0 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 ) ],
[ qw( 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 0 0 0 0 0 0 0 0 1 1 1 1 1 1 1 1 ) ],
[ qw( 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 0 0 0 0 0 0 0 0 ) ],
[ qw( 0 0 0 0 0 0 0 0 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 ) ],
[ qw( 1 1 1 1 1 1 1 1 0 0 0 0 0 0 0 0 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 ) ],
[ qw( 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 0 0 0 0 0 0 0 0 1 1 1 1 1 1 1 1 ) ],
[ qw( 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 0 0 0 0 0 0 0 0 ) ],
[ qw( 0 0 0 0 0 0 0 0 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 ) ],
[ qw( 1 1 1 1 1 1 1 1 0 0 0 0 0 0 0 0 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 ) ],
[ qw( 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 0 0 0 0 0 0 0 0 1 1 1 1 1 1 1 1 ) ],
[ qw( 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 0 0 0 0 0 0 0 0 ) ],
);
$ga->inject(\@helper);
# evolve 1000 generations
$ga->evolve(1000);
ok($Win == $ga->as_value($ga->getFittest));
( run in 0.525 second using v1.01-cache-2.11-cpan-4d50c553e7e )