libxray-spacegroup-perl 0.1.1-3 / usr / share / perl5 / Xray / SpaceGroup.pm

package Xray::SpaceGroup;

=for Copyright
 .
 Copyright (c) 1999-2008 Bruce Ravel (bravel AT bnl DOT gov).
 All rights reserved.
 .
 This file is free software; you can redistribute it and/or
 modify it under the same terms as Perl itself. See The Perl
 Artistic License.
 .
 This program is distributed in the hope that it will be useful,
 but WITHOUT ANY WARRANTY; without even the implied warranty of
 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.

=cut

use strict;
use warnings;
#use diagnostics;
use Carp;
use Class::Std;
use File::Spec;
use List::MoreUtils qw(any true);
use Regexp::List;
use Storable;

use Readonly;
Readonly my $EPSILON  => 0.00001;

use vars qw($VERSION);
use version;
$VERSION = version->new("0.1.0");

# use Data::Dumper;

sub identify_self {
  my @caller = caller;
  use File::Basename qw(dirname);
  return dirname($caller[1]);
};

{

  my %params_of  :ATTR;
  my $database = File::Spec->catfile(identify_self(), 'SpaceGroup', 'space_groups.db');
  my $r_sg = retrieve($database);

  my $opt  = Regexp::List->new;
  my $number_attr = $opt->list2re(qw(a b c alpha beta gamma));
  my $sh_re = $opt->list2re(qw(hex hcp zincblende zns cubic salt perov perovskite
			       gra graphite fcc salt nacl diamond bcc cscl));

  sub START {
    my ($self, $ident, $arguments) = @_;
    #$self->set({file=>q{}, entries=>[]});
    #print ref($arguments), $/;
    $arguments = {group=>$arguments} if (ref($arguments) eq 'SCALAR');
    $self->set($arguments);
  };

  sub set {
    my ($self, $arguments) = @_;
    foreach my $key (keys %$arguments) {
      my $k = lc $key;
      $params_of{ident $self}{$k} = $arguments->{$k};
      if ($k eq 'group') {
	$params_of{ident $self}{given_group} = $arguments->{$k};
	$params_of{ident $self}{setting} = 0;
	$self->_canonicalize_group;
	$self->_set_bravais;
	$self->_crystal_class;
	#$self->_determine_monoclinic;
      };
    };
  };

  sub get {
    my ($self, @params) = @_;
    croak('$type: usage: get($key) or get(@keys)') if @_ < 2;
    my @values = ();
    foreach my $key (@params) {
      my $k = lc $key;
      push @values, $params_of{ident $self}{$k};
    };
    return wantarray ? @values : $values[0];
  };

  sub group :STRINGIFY {
    my ($self) = @_;
    return $params_of{ident $self}{space_group};
  };
  sub given {
    my ($self) = @_;
    return $params_of{ident $self}{given_group};
  };
  sub number :NUMERIFY {
    my ($self) = @_;
    return $r_sg->{$self}->{number};
  };
  sub full {
    my ($self) = @_;
    return $r_sg->{$self}->{full};
  };
  sub schoenflies {
    my ($self) = @_;
    return $r_sg->{$self}->{schoenflies};
  };
  sub thirtyfive {
    my ($self) = @_;
    return $r_sg->{$self}->{thirtyfive};
  };
  sub newsymbol {
    my ($self) = @_;
    return $r_sg->{$self}->{new_symbol};
  };
  sub class {
    my ($self) = @_;
    return $params_of{ident $self}{class};
  };
  sub nicknames {
    my ($self) = @_;
    my $list_ref = $r_sg->{$self}->{shorthand} || [];
    return @$list_ref;
  };

  sub setting {
    my ($self) = @_;
    return $params_of{ident $self}{setting}
  };
  sub bravais {
    my ($self) = @_;
    my $list_ref = $params_of{ident $self}{bravais} || [];
    return @$list_ref;
  };


  sub warning {
    my ($self) = @_;
    return $params_of{ident $self}{warning};
  };
  sub positions {
    my ($self) = @_;
    my $list_ref = [];

    ## R groups in  the rhombohedral setting
    if ( ($self->get('space_group') =~ m{\Ar}) and ($self->get('setting') eq 'rhombohedral') ) {
      $list_ref = $r_sg->{$self}->{rhombohedral};

    ## monoclinic group settings
    } elsif ( $self->get('class') eq 'monoclinic' ) {
      my $this = $self->get('setting');
      $list_ref = $r_sg->{$self}->{$this} || [];

    ## everything else uses the "positions" entry
    } else {
      $list_ref = $r_sg->{$self}->{positions} || [];
    };
    return @$list_ref;
  };


  sub report {
    my ($self) = @_;
    my $message = sprintf("Space group: %s (%d)\n",    $self, $self);
    $message   .= sprintf("  supplied symbol        : %s\n", $self->given);
    $message   .= sprintf("  crystal class          : %s\n", $self->class);
    $message   .= sprintf("    Schoenflies symbol   : %s\n", $self->schoenflies);
    $message   .= sprintf("    full symbol          : %s\n", $self->full)                  if $self->full;
    $message   .= sprintf("    1935 symbol          : %s\n", $self->thirtyfive)            if $self->thirtyfive;
    $message   .= sprintf("    new symbol           : %s\n", $self->newsymbol)             if $self->newsymbol;
    $message   .= sprintf("    nicknames            : %s\n", join(", ", $self->nicknames)) if $self->nicknames;
    $message   .= sprintf("    crystal setting      : %s\n", $self->setting);
    $message   .= "    Bravais translations :\n";
    my @brav    = map { _simple_fraction($_) } $self->bravais;
    $message   .= "      none\n"                                                                                   if not @brav;
    $message   .= sprintf("      %-7s   %-7s   %-7s\n",                                                     @brav) if ($#brav == 2);
    $message   .= sprintf("      %-7s   %-7s   %-7s\n      %-7s   %-7s   %-7s\n",                           @brav) if ($#brav == 5);
    $message   .= sprintf("      %-7s   %-7s   %-7s\n      %-7s   %-7s   %-7s\n      %-7s   %-7s   %-7s\n", @brav) if ($#brav == 8);
    $message   .= "    Positions :\n";
    foreach my $p ($self->positions) {
      $message .= sprintf("      %-7s   %-7s   %-7s\n", @$p);
    };
    return $message;
  };

  sub _simple_fraction {		# stringify Bravais fractions
    my ($val) = @_;
    return (abs($val - 1/2) < $EPSILON) ? '1/2'
         : (abs($val - 1/3) < $EPSILON) ? '1/3'
         : (abs($val - 2/3) < $EPSILON) ? '2/3'
         :                                '0';
  };


  sub _canonicalize_group {
    my ($self) = @_;
    my $symbol = $params_of{ident $self}{given_group};
    my @mono3 = qw(b_unique c_unique a_unique);
    my @mono9 = qw(b_unique_1 b_unique_2 b_unique_3 c_unique_1 c_unique_2 c_unique_3 a_unique_1 a_unique_2 a_unique_3);
				# this is a null value
    $params_of{ident $self}{warning}     = q{};
    if (! $symbol) {
      $params_of{ident $self}{space_group} = q{};
      $params_of{ident $self}{setting}     = 0;
      $params_of{ident $self}{data}        = q{};
      $params_of{ident $self}{warning}     = q{Your symbol could not be recognized as a space group symbol!};
      return (q{},0);
    };

    $symbol = lc($symbol);	# lower case and ...
    $symbol =~ s{[!\#%*].*$}{};  # trim off comments
    $symbol =~ s{^\s+}{};	# trim leading spaces
    $symbol =~ s{\s+$}{};	# trim trailing spaces
    $symbol =~ s{\s+}{ }g;	# ... single space
    $symbol =~ s{\s*/\s*}{/}g;	# spaces around slash

    $symbol =~ s{2_1}{21}g;	  # replace `i 4_1' with `i 41'
    $symbol =~ s{3_([12])}{3$1}g; #  and so on ...
    $symbol =~ s{4_([1-3])}{4$1}g;
    $symbol =~ s{6_([1-5])}{6$1}g;

    if ( ($symbol !~ m{[_^]})        and  # schoen
	 ($symbol !~ m{\A\d{1,3}\z}) and  # 1-230
	 ($symbol !~ m{\A($sh_re)\z}io)   # shorthands like 'cubic', 'zns'
       ) {
      #print $symbol;
      $symbol = _insert_spaces($symbol);
      #print "|$symbol|\n";
    };
				# this is the standard symbol
    if (exists($r_sg->{$symbol})) {
      $params_of{ident $self}{space_group} = $symbol;
      $params_of{ident $self}{setting}     = (any {$r_sg->{$symbol}->{number} eq $_} (3..6, 10..12) ) ? "b_unique"
	                                   : (any {$r_sg->{$symbol}->{number} eq $_} (7..9, 13..15) ) ? "b_unique_1"
					   :                                                            "positions";
      my $rhash = $r_sg->{$symbol};
      $params_of{ident $self}{data}        = $rhash;
      return ($symbol, 0);
    };

    foreach my $sym (keys %$r_sg ) {
      next if ($sym eq "version");
      my $rhash = $r_sg->{$sym};

				# this is the Schoenflies symbol, (it
				# must have a caret in it)
      if ($symbol =~ /\^/) {
	$symbol =~ s/\s+//g;	#   no spaces
	$symbol =~ s/^v/d/g;	#   V -> D
				# put ^ and _ in correct order
	$symbol =~ s/([cdost])(\^[0-9]{1,2})(_[12346dihsv]{1,2})/$1$3$2/;
	if ((exists $r_sg->{$sym}->{schoenflies}) and ($symbol eq $r_sg->{$sym}->{schoenflies}) ) {
	  $params_of{ident $self}{space_group} = $sym;
	  $params_of{ident $self}{setting}     = (any {$r_sg->{$sym}->{number} eq $_} (3..6, 10..12) ) ? "b_unique"
 	                                       : (any {$r_sg->{$sym}->{number} eq $_} (7..9, 13..15) ) ? "b_unique_1"
					       :                                                         "positions";
	  $params_of{ident $self}{data}        = $rhash;
	  return ($sym, 0);
	};
      };
				# scalar valued fields
				# this is a number between 1 and 230
				#    or the 1935 symbol
 				#    or a double glide plane symbol
 				#    or the full symbol
      foreach my $field ("thirtyfive", "number", "new_symbol", "full") {
	if ( (exists $r_sg->{$sym}->{$field}) and ($symbol eq $r_sg->{$sym}->{$field}) ) {
	  $params_of{ident $self}{space_group} = $sym;
	  $params_of{ident $self}{setting}     = (any {$r_sg->{$sym}->{number} eq $_} (3..6, 10..12) ) ? "b_unique"
 	                                       : (any {$r_sg->{$sym}->{number} eq $_} (7..9, 13..15) ) ? "b_unique_1"
					       :                                                         "positions";
	  $params_of{ident $self}{data}        = $rhash;
	  return ($sym, 0);
	};
      };
				# now check the array values fields
      foreach my $field ("settings", "short", "shorthand") {
	if (exists($r_sg->{$sym}->{$field})) {
	  my $i=0;
	  my $count = -1;
	  foreach my $setting ( @{$r_sg->{$sym}->{$field}} ) {
	    ++$count;
	    ++$i;
	    my $s = ($field eq "settings") ? $i : 0;
	    if ($symbol eq $setting) {
	      $params_of{ident $self}{space_group} = $sym;
	      if (any {$field eq $_} qw(settings short)) {
		if (any {$r_sg->{$sym}->{number} eq $_} (3..6, 10..12) ) {
		  $params_of{ident $self}{setting}     = $mono3[$count];
		} elsif (any {$r_sg->{$sym}->{number} eq $_} (7..9, 13..15) ) {
		  $params_of{ident $self}{setting}     = $mono9[$count];
		};
	      };
	      $params_of{ident $self}{data}        = $rhash;
	      return ($sym, $s);
	    };
	  };
	};
      };

    };

				# this is not a symbol
    $params_of{ident $self}{space_group} = q{};
    $params_of{ident $self}{setting}     = 0;
    $params_of{ident $self}{data}        = {};
    $params_of{ident $self}{warning}     = q{Your symbol could not be recognized as a space group symbol!};
    return (q{},0);

  }


  ## This is the algorithm for dealing with user-supplied space group
  ## symbols that do not have the canonical single space separating the
  ## part of the symbol.
  sub _insert_spaces {
    my $sym = $_[0];

    my ($first, $second, $third, $fourth) = ("", "", "", "");

    ## a few groups don't follow the rules below ...
    ($sym =~ /\b([rhc])32\b/i)                 && return "$1 3 2";
    ($sym =~ /\bp31([2cm])\b/i)                && return "p 3 1 $1";
    ($sym =~ /\bp(3[12]?)[22][12]\b/i)         && return "p $1 2 1";
    ($sym =~ /\bp(6[1-5]?)22\b/i)              && return "p $1 2 2";
    ($sym =~ /\b([fip])(4[1-3]?)32\b/i)        && return "$1 $2 3 2";
    ($sym =~ /\b([fipc])(4[1-3]?)(21?)(2)\b/i) && return "$1 $2 $3 $4";

    ## the first symbol is always a single letter
    $first = substr($sym, 0, 1);
    my $index = 1;

    my $subsym = substr($sym, $index);
    if ($subsym =~ m{\A([ \t]+)}) {
      $index += length($1);
    };
    if (substr($sym, $index, 4) =~ /([2346][12345]\/[mnabcd])/) {
      ## second symbol as in p 42/n c m
      $second = $1;
      $index += 4;
    } elsif (substr($sym, $index, 3) =~ /([2346]\/[mnabcd])/) {
      ## second symbol as in p 4/n n c
      $second = $1;
      $index += 3;
    } elsif (substr($sym, $index, 2) =~ /(-[1346])/) {
      ## second symbol as in p -3 1 m
      $second = $1;
      $index += 2;
    } elsif (substr($sym, $index, 2) =~ /(21|3[12]|4[123]|6[12345])/) {
      ## second symbol as in p 32 1 2
      $second = $1;
      $index += 2;
    } else {
      $second = substr($sym, $index, 1);
      $index += 1;
    };

    $subsym = substr($sym, $index);
    if ($subsym =~ m{\A([ \t]+)}) {
      $index += length($1);
    };
    if (substr($sym, $index, 4) =~ /([2346][12345]\/[mnabcd])/) {
      ## third symbol as in full symbol p 21/c 21/c 2/n
      $third = $1;
      $index += 4;
    } elsif (substr($sym, $index, 3) =~ /([2346]\/[mnabcd])/) {
      ## third symbol as in full symbol p 4/m 21/b 2/m
      $third = $1;
      $index += 3;
    } elsif (substr($sym, $index, 2) =~ /(-[1346])/) {
      ## third symbol as in f d -3 m
      $third = $1;
      $index += 2;
    } elsif (substr($sym, $index, 2) =~ /(21|3[12]|4[123]|6[12345])/) {
      ## third symbol as in p 21 21 2
      $third = $1;
      $index += 2;
    } else {
      $third = substr($sym, $index, 1);
      $index += 1;
    };

    ($index < length($sym)) and $fourth = substr($sym, $index);
    $fourth =~ s/\A\s+//;

    $sym = join(" ", $first, $second, $third, $fourth);
    $sym =~ s/\s+$//;		# trim trailing spaces
    return $sym;
  };


  sub _set_bravais {
    my ($self) = @_;
    my %table = ( f => [  0, 1/2, 1/2, 1/2,   0, 1/2, 1/2, 1/2,   0],
		  i => [1/2, 1/2, 1/2],
		  c => [1/2, 1/2,   0],
		  a => [  0, 1/2, 1/2],
		  b => [1/2,   0, 1/2],
		  r => [2/3, 1/3, 1/3, 1/3, 2/3, 2/3],
		);
    my $group   = $self->get("given_group");
    my $g       = lc(substr($group, 0, 1));
    if ($g !~ m{[ficabr]}) {
      $group   = $self->get("space_group");
      $g       = lc(substr($group, 0, 1));
    };
    my $setting = $self->get("setting");
    $params_of{ident $self}{bravais} = [];
    $params_of{ident $self}{bravais} = $table{r}  if (($g eq 'r') and ($setting eq "rhombohedral"));
    $params_of{ident $self}{bravais} = $table{$g} if ($g =~ m{[abcfi]});
    return $self;;
  };


  sub _crystal_class {
    my ($self)  = @_;
    my $group   = $self->get("space_group");
    if (exists $r_sg->{$group}->{number}) {
      my $num   = $r_sg->{$group}->{number};
      my $class = ($num <= 0)   ? q{}
	        : ($num <= 2)   ? "triclinic"
	        : ($num <= 15)  ? "monoclinic"
	        : ($num <= 74)  ? "orthorhombic"
	        : ($num <= 142) ? "tetragonal"
	        : ($num <= 167) ? "trigonal"
	        : ($num <= 194) ? "hexagonal"
	        : ($num <= 230) ? "cubic"
	        : q{};
      $params_of{ident $self}{class} = $class;
      if (($class eq 'monoclinic') and (not $params_of{ident $self}{setting})) {
	$params_of{ident $self}{setting}  = "b_unique";
	$params_of{ident $self}{setting} .= "_1" if any {$r_sg->{$self}->{number} == $_} (7,9,13,14,15);
      };
    } else {
      $params_of{ident $self}{class} = q{};
    };
    return 1;
  };


  sub fix {
    my ($self, $args) = @_;
    $args->{alpha} ||= 90;
    $args->{beta}  ||= 90;
    $args->{gamma} ||= 90;

    ## determine correct setting for monoclinic groups by examining angles
    $self -> _determine_monoclinic($args);

  CHECK: {
      ($self->get('class') eq 'cubic') and do {
	if ( (abs($args->{a} - $args->{b}) > $EPSILON) or
	     (abs($args->{b} - $args->{c}) > $EPSILON) or
	     (abs($args->{a} - $args->{c}) > $EPSILON) or
	     (abs($args->{alpha} - 90)     > $EPSILON) or
	     (abs($args->{beta}  - 90)     > $EPSILON) or
	     (abs($args->{gamma} - 90)     > $EPSILON) ) {
	  $params_of{ident $self}{warning} = "Cubic space groups should have all axes equal and all angle of 90 degrees.";
	};
	last CHECK;
      };

      ($self->get('class') =~ m{(hexagonal|trigonal)}) and do {
	if ( (abs($args->{a} - $args->{b}) > $EPSILON) or
	     (abs($args->{a} - $args->{c}) < $EPSILON) or
	     (abs($args->{b} - $args->{c}) < $EPSILON) or
	     (abs($args->{alpha} - 90)     > $EPSILON) or
	     (abs($args->{beta}  - 90)     > $EPSILON) or
	     (abs($args->{gamma} - 120)    > $EPSILON) ) {
	  my $which = ucfirst($1);
	  $params_of{ident $self}{warning} = "$which space groups should have a=b with c different, alpha=beta=90 degrees, and gamma=120 degrees.";
	};
	last CHECK;
      };

      ($self->get('class') eq 'tetragonal') and do {
	if ( (abs($args->{a} - $args->{b}) > $EPSILON) or
	     (abs($args->{a} - $args->{c}) < $EPSILON) or
	     (abs($args->{b} - $args->{c}) < $EPSILON) or
	     (abs($args->{alpha} - 90)     > $EPSILON) or
	     (abs($args->{beta}  - 90)     > $EPSILON) or
	     (abs($args->{gamma} - 90)     > $EPSILON) ) {
	  $params_of{ident $self}{warning} = "Tetragonal space groups should have a=b with c different, alpha=beta=gamma=90 degrees.";
	};
	last CHECK;
      };

      ($self->get('class') eq 'orthorhombic') and do {
	if ( (abs($args->{a} - $args->{b}) < $EPSILON) or
	     (abs($args->{a} - $args->{c}) < $EPSILON) or
	     (abs($args->{b} - $args->{c}) < $EPSILON) or
	     (abs($args->{alpha} - 90)     > $EPSILON) or
	     (abs($args->{beta}  - 90)     > $EPSILON) or
	     (abs($args->{gamma} - 90)     > $EPSILON) ) {
	  $params_of{ident $self}{warning} = "Orthorhombic space groups should have all axes unequal and alpha=beta=gamma=90 degrees.";
	};
	last CHECK;
      };

      ($self->get('class') eq 'monoclinic') and do {
	if ( (abs($args->{a} - $args->{b}) < $EPSILON) or
	     (abs($args->{a} - $args->{c}) < $EPSILON) or
	     (abs($args->{b} - $args->{c}) < $EPSILON) or
	     ( (true {abs($_ - 90) > $EPSILON} ($args->{alpha}, $args->{beta}, $args->{gamma}) ) != 1) ) {
	  $params_of{ident $self}{warning} = "Monoclinic space groups should have all axes unequal and one angle not equal to 90 degrees.";
	};
	last CHECK;
      };

      ($self->get('class') eq 'triclinic') and do {
	if ( (abs($args->{a} - $args->{b}) < $EPSILON) or
	     (abs($args->{a} - $args->{c}) < $EPSILON) or
	     (abs($args->{b} - $args->{c}) < $EPSILON) or
	     (abs($args->{alpha} - 90)     < $EPSILON) or
	     (abs($args->{beta}  - 90)     < $EPSILON) or
	     (abs($args->{gamma} - 90)     < $EPSILON) ) {
	  $params_of{ident $self}{warning} = "Triclinic space groups should have all axes unequal and all angles unequal.";
	};
	last CHECK;
      };

    };
  };

  sub _determine_monoclinic {
    my ($self, $args) = @_;
    $args->{alpha} ||= 90;
    $args->{beta}  ||= 90;
    $args->{gamma} ||= 90;
    my ($group, $given, $class) = $self->get(qw(space_group given_group class));
    return 0 if ($class ne "monoclinic");
    ($given = $group) if ($given =~ m{\A\d+\z});

    my $axis = ((abs( 90 - $args->{alpha} )) > $EPSILON) ? "a"
             : ((abs( 90 - $args->{beta}  )) > $EPSILON) ? "b"
	     : ((abs( 90 - $args->{gamma} )) > $EPSILON) ? "c"
	     : q{};
    #(! $axis) && do {
    #  if ($self->get("angle")) {
    #	$axis = lc(substr($self->get('angle'), 0, 1));
    #	$axis =~ tr/g/c/;
    #  };
    #};
    #print "axis: $axis\n";
    return 0 if (not $axis);	#  angles not set yet

    # if it has, then continue...
    my $setting = $axis . "_unique";
    my $number  = $r_sg->{$group}->{number};
    ## these groups have one cell choice for each unique axis
    foreach my $n (3,4,5,6,8,10,11,12) {
      ($number == $n) && return $setting;
    };
    ## groups 7, 13, 14 are p centered and have multiple cell choices
    #print "$group   $given    $axis\n";
    if ($group =~ m{\Ap}) {
      if ($axis eq "b") {
	($setting .= "_1") if ($given =~ m{c}i);
	($setting .= "_2") if ($given =~ m{n}i);
	($setting .= "_3") if ($given =~ m{a}i);
      } elsif ($axis eq "c") {
	($setting .= "_1") if ($given =~ m{a}i);
	($setting .= "_2") if ($given =~ m{n}i);
	($setting .= "_3") if ($given =~ m{b}i);
      } elsif ($axis eq "a") {
	($setting .= "_1") if ($given =~ m{b}i);
	($setting .= "_2") if ($given =~ m{n}i);
	($setting .= "_3") if ($given =~ m{c}i);
      };
    };
    ## groups 9, 15 are c centered and have multiple cell choices
    if ($group =~ m{\Ac}) {
      if ($axis eq "b") {
	($setting .= "_1") if ($given =~ m{\Ac}i);
	($setting .= "_2") if ($given =~ m{\Aa}i);
	($setting .= "_3") if ($given =~ m{\Ai}i);
      } elsif ($axis eq "c") {
	($setting .= "_1") if ($given =~ m{\Aa}i);
	($setting .= "_2") if ($given =~ m{\Ab}i);
	($setting .= "_3") if ($given =~ m{\Ai}i);
      } elsif ($axis eq "a") {
	($setting .= "_1") if ($given =~ m{\Ab}i);
	($setting .= "_2") if ($given =~ m{\Ac}i);
	($setting .= "_3") if ($given =~ m{\Ai}i);
      };
    };
    ## if none of the preceding 6 blocks altered setting then there is a
    ## mismatch between the symbol and the unique axis, so return 0.
    ($setting = 0) if ($setting !~ /_[123]$/);
    $params_of{ident $self}{setting} = $setting;
    return $setting;
  };

};
1;



=head1 NAME

Xray::SpaceGroup - Symmetry operations for the crystal space groups

=head1 VERSION

This documentation refers to libperlxray version 0.1.

=head1 SYNOPSIS

   my $sg = Xray::SpaceGroup -> new("Pm3m");
   $sg -> fix({a     => $a,     b    => $b,    c     => $c,
               alpha => $alpha, beta => $beta, gamma => $gamma})
   @symmetry_ops  = $sg -> positions;
   @bravais_trans = $sg -> bravais;
   print $sg -> report;

The two lists can be used to populate a unit cell, given a set of
Wyckoff positions.  The report is a user-readable summary of the
properties of the space group.

=head1 DESCRIPTION

This provides an object-oriented interface to a database of space
group symmetries transcribed from volume A of the International Tables
for Crystallography.

=head1 METHODS

=head2 Accessor Methods

=over 4

=item C<new>

This creates a new Xray::SpaceGroup object.

  my $sg = Xray::SpaceGroup -> new({group=>"Pm3m"});

The space group symbol can be a Hermann-Maguin symbol, a Schoenflies
symbol, the number of the space group, one of several nicknames
(diamond, cscl, etc), or a few other symbols from the International
Tables.

The H-M symbol can contain any number of spaces and is case
insensitive.  An overscore is indicated by a leading dash (C<->) and a
subscript is simply written as a normal character, as in C<p 42 3 2>
where "4 sub 2" is written as C<42>.  A slash is indicated by a
forward slash (C</>).

The sub- and superscripts of the Schoenflies symbol can come in either
order and are indicated by caret (C<^>) and underscore (C<_>).

The nicknames are as follows:

    symbol       number        nicknames
   ------------------------------------------------------------
    p 63 m c      186        graphite, gra
    p 63/m m c    194        hex, hcp
    f -4 3 m      216        zincblende, zns
    p m -3 m      221        cubic, cscl, perov, perovskite
    f m -3 m      225        fcc, salt, nacl
    f m -3 d      227        diamond
    i m -3 m      229        bcc

=item C<fix>

Set the crystal setting based on the values of the lattice constants
and verify that the lattice constants make sense for the selected
crystal class.

   $sg -> fix({a     => $a,     b    => $b,    c     => $c,
               alpha => $alpha, beta => $beta, gamma => $gamma})

The first chore of this method is quite necessary for a space group
with multiple settings.  Selecting the correct setting requires
knowledge of the lattice parameters.  For many space groups, including
all cubic groups, this is a no-op.

=item C<warning>

This will return a non-empty string if a problem was found in the
C<fix> method.  Most such problems result from a mismatch between the
lattice constant values and what is expected for the crystal class.
For instance, if a monoclinic space group symbol is given but all
three angles are 90 degrees, a warning will be returned by this
method.  This sort of problem rarely requires that your program stops,
so no explicit exception is thrown when C<fix> finds a problem.  If
you want to know whether a problem was found, you must explicitly call
this method.

=item C<positions>

This method is the meaty part of this module.  This returns a list of
lists containing the symmetry operations for your space group and the
appropriate crystal setting.  Here is an example using a monoclinic
space group, which has a short list of symmetry operations.

    use Data::Dumper;
    my $sg = Xray::SpaceGroup -> new({group=>'7'});
    my @positions = $sg->positions;
    print Data::Dumper->Dump([\@positions], [qw(positions)]);
      ==prints==>
        $positions = [
                      [ '$x', '$y', '$z'      ],
                      [ '$x', '-$y', '$z+1/2' ]
                     ];

The elements of these lists are strings and are intended to be
evaluated using perl's eval function.  For example, if you have a
Wyckoff position of C<(0.2, 0.3, 0.4)>, then you might do this:

    ($x, $y, $z) = (0.2, 0.3, 0.4);
    @pos0 = (eval "$positions[0]->[0]",
             eval "$positions[0]->[1]",
             eval "$positions[0]->[2]"  );
    @pos1 = (eval "$positions[1]->[0]",
             eval "$positions[1]->[1]",
             eval "$positions[1]->[2]"  );

This will result in C<@pos0 = (0.2, 0.3, 0.4)> and C<@pos2 = (0.2,
-0.3, 0.9)>.  You would, in practice, wrap these evaluations inside
proper control structures.  You might also use a L<Safe> compartment
if you are worried about the possibility of the database having been
tainted.

For high symmetry groups and high symmetry Wyckoff positions, these
evaluations will generate the same positions repeatedly.  It is the
responsibility of your application to weed out these repetitions.

=back

There are also C<set> and C<get> methods, but properties of the space
group should be obtained via the reporting methods listed below.

=head2 Reporting Methods

=over 4

=item C<report>

This writes a summary of the properties of the space group in a
human-readable form.

   my $space = Xray::SpaceGroup -> new({group=>7});
   print join(", ", $space->bravais), $/;
    ==prints==>
       Space group: p c (7)
         supplied symbol        : 7
         crystal class          : monoclinic
           Schoenflies symbol   : c_s^2
           crystal setting      : b_unique_1
           Bravais translations :
             none
           Positions :
             $x           $y           $z
             $x           -$y          $z+1/2

=item C<group>

This returns the canonical space symbol for this space group.

   print $sg->group, $/;
    ==prints==>
       p m -3 m

=item C<given>

This returns the space symbol supplied when the object was created.

   print $sg->given, $/;
    ==prints==>
       Pm3m

=item C<number>

This returns the number of the space group as in the International
Tables.

   print $sg->number, $/;
    ==prints==>
       221

=item C<full>

This returns the full symbol of the space group as in the
International Tables.

   print $sg->full, $/;
    ==prints==>
       p 4/m -3 2/m

=item C<schoenflies>

This returns the Schoenflies symbol of the space group.

   print $sg->schoenflies, $/;
    ==prints==>
       o_h^1

=item C<thirtyfive>

This returns the symbol of the space group as it appeared in the 1935
edition of the International Tables, if it was different from the
canonical symbol.  Otherwise this returns an empty string.

   print $sg->thirtyfive, $/;
    ==prints==>
       p m 3 m

=item C<newsymbol>

This returns the new symbol of the space group as introduced by the
IUCr nomenclature report of 1992.  Only a handful of groups with glide
planes have new symbols.  An empty string is returned for most groups.

   my $sgnew = Xray::SpaceGroup -> new({group=>"a b a 2"});
   print $sgnew->newsymbol, $/;
    ==prints==>
       a e a 2

=item C<class>

This returns the crystal class of the space group

   print $sg->class, $/;
    ==prints==>
       cubic

=item C<setting>

This returns the setting of the space group using the nomenclature of
the database used by this module.  If there is only one setting, this
returns 0.

For rhombohedral space groups, this returns a string -- either
"positions" or "rhombohedral" -- indicating which set of symmetry
operations should be used.

For most monoclinic groups, this returns one of "b_unique",
"c_unique", or "a_unique", indicating which set of symmetry operations
should be used.  If the beta angle is not 90 degrees, the "b_unique"
setting should be used.  If the gamma or alpha angles are not 90
degrees, the "c_unique" or "a_unique" settings should be used,
respectively.

For several monoclinic space groups, there are additional settings for
each unique axis. These are indicated as "b_unique_1", "b_unique_2",
"b_unique_3", and so on.

=item C<bravais>

This returns a 0, 3, 6, or 9 element list containing the Bravais
translation vectors associated with the space group.

   my $diamond = Xray::SpaceGroup -> new({group=>"f d -3 m"});
   print join(", ", $diamond->bravais), $/;
    ==prints==>
        0.000, 0.500, 0.500, 0.500, 0.000, 0.500, 0.500, 0.500, 0.000

Each triplet is a Bravais translation.

The Bravais translations attempt to be sensitive to the specified
crystal setting.  If you use ambiguous input (i.e. the number or the
Schoenflies symbol) it is possible that a Bravais translation other
than the one you want will be returned.  The telepathic interface is
planned for version 2.0.

=back

=head1 COERCIONS

When the reference to the Xray::SpaceGroup object is used in string
context, the C<group> method is returned.  When used in numerical
context, the C<number> method is returned.

=head1 CONFIGURATION AND ENVIRONMENT

This requires that the F<space_groups.db> file, which is generated by
the F<space_groups.db.PL> script, be installed in the correct location.
There are no other configuration options.

=head1 DEPENDENCIES

This module uses several things from the standard distribution along
with:

L<Class::Std>

L<List::MoreUtils>

L<Readonly>

L<Regexp::List>

=head1 BUGS AND LIMITATIONS

Missing features:

=over 4

=item *

Groups 5, 8, 12 list 9 symbols, but 3 sets of positions.  What's up
with that?

=item *

Groups 12 - 15, short notation is ambiguous, requires angles to
resolve.

=item *

C<_determine_monoclinic> should use alpha/beta/gamma,
C<_canonicalize_group> already parsed the given_group

=item *

Recognize setting for R groups

=item *

Rotate symmetry ops for orthorhombic groups to the setting specified
by the symbol.  In atoms, I rotate the coordinates and rotate them
back.  Rotating the symmetry ops is a better, more general purpose
solution.

=item *

Handle alternate tetragonal group settings here rather than in the
application.

=back

Please report problems to Bruce Ravel (bravel AT bnl DOT gov)

Patches are welcome.

=head1 AUTHOR

Bruce Ravel (bravel AT bnl DOT gov)

http://cars9.uchicago.edu/~ravel/software/

=head1 ACKNOWLEDGEMENTS

Julie Cross and Matt Newville gave me a copy of volume A of the
International Tables for Crystallography as a graduation present from
grad school.  Was that a blessing or a curse?

Saulius Grazulis, whose useful feedback inspired this most recent
rewrite of this code.  Earlier versions of Atoms benefited from the
help and criticism of Shelly Kelly, Daniel Haskel, Chuck Bouldin,
Hannes Fischer, Glenn Forney, Chris Glover, John Rehr, Hubert
Renevier, Julia Wienold, Andrzej Wilamowski, Boyan Boyanovich, Ed
Stern, Hans Stragier, Kalle Voss, Steve Zabinsky, and Yanjun Zhang.
All the users of my codes over the years have driven me to provide the
best possible code.

=head1 LICENCE AND COPYRIGHT

Copyright (c) 1999-2008 Bruce Ravel (bravel AT bnl DOT gov). All rights reserved.

This module is free software; you can redistribute it and/or
modify it under the same terms as Perl itself. See L<perlartistic>.

This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.

=cut