This file is indexed.

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

This file is owned by root:root, with mode 0o644.

The actual contents of the file can be viewed below.

  1
  2
  3
  4
  5
  6
  7
  8
  9
 10
 11
 12
 13
 14
 15
 16
 17
 18
 19
 20
 21
 22
 23
 24
 25
 26
 27
 28
 29
 30
 31
 32
 33
 34
 35
 36
 37
 38
 39
 40
 41
 42
 43
 44
 45
 46
 47
 48
 49
 50
 51
 52
 53
 54
 55
 56
 57
 58
 59
 60
 61
 62
 63
 64
 65
 66
 67
 68
 69
 70
 71
 72
 73
 74
 75
 76
 77
 78
 79
 80
 81
 82
 83
 84
 85
 86
 87
 88
 89
 90
 91
 92
 93
 94
 95
 96
 97
 98
 99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
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