root/lang/perl/Class-Logic/trunk/lib/Class/Logic.pm @ 15348

Revision 15348, 12.8 kB (checked in by lieutar, 6 years ago)

emended the api document

Line 
1
2use strict;
3use warnings;
4
5=pod
6
7=head1 NAME
8
9Class::Logic - arbitrary logical calculator.
10
11=cut
12
13package Class::Logic;
14
15our $VERSION = '0.01';
16our $AUTHOR  = 'lieutar';
17
18require Sub::Exporter;
19use Sub::Exporter;
20use Sub::Name;
21use Moose;
22use Carp;
23use UNIVERSAL qw( isa  can );
24
25=pod
26
27=head1 SYNOPSIS
28
29=over 4
30
31=item as a Module
32
33  package Logic::WithDefault;
34  use Class::Logic '-define';
35
36  rule 'default'
37     => bool => 1
38
39     => and  => {qw( default default
40                      true    true
41                      false   false )}
42
43     =>  or  => {qw( default default
44                     true    true
45                     false   false )}
46
47
48
49  use Logic::WithDefault;
50  print 'false' unless OR( default , default, false );
51
52=item OO interface
53
54  # well-known logic
55  use Class::Logic;
56  my $c0 = Class::Logic->new;
57  $c0->rule( 'null'  => bool => undef );
58  $c0->default('null');
59 
60 
61  my $c1 = Class::Logic->new;
62  $c1->rule( 'default'
63
64              => bool => 1
65
66              => and  => {qw{ default default
67                              true    true
68                              false   false }}
69
70              =>  or  => {qw( default default
71                              true    true
72                              false   false )});
73  my $d = $c1->sym('default');
74  print 'false' unless $d->or('default')->or('false');
75  # same as
76  print 'false' unless $c1->calc(or => $c1->calc(or => 'default', 'default'),
77                                       'false');
78
79=back
80
81=head1 DESCRIPTION
82
83This module provides easy means for creating modules
84that provides arbitrary logical calculation methods.
85
86=head1 OO approach
87
88=head2 Attributes and Accessors.
89
90=over 4
91
92=item C<name>
93
94Name of the calculator. This attribute is not modifiable.
95
96=item C<rules>
97
98This is reference to a HASH dictionary
99which contains all rules for the calculator.
100This attribute is not modifiable.
101
102=item C<default>
103
104The default symbol. This symbol is returned when
105a rule of requested calculation is not defined.
106
107This attribute is modifiable.
108
109=item C<or_default>
110
111A default symbol for C<OR> function. This symbol is returned when
112C<OR> function is called with no arguments.
113
114This attribute has no point in an OO approach.
115
116This attribute is modifiable.
117
118=item C<and_default>
119
120A default symbol for C<AND> function. This symbol is returned when
121C<AND> function is called with no arguments.
122
123This attribute has no point in an OO approach.
124
125This attribute is modifiable.
126
127=back
128
129=cut
130
131has name => ( is      => 'ro',
132              isa     => 'Str',
133              default => '__ANON__');
134
135has rules => ( is    => 'ro',
136               isa   => 'HashRef',
137               default => sub{{
138                             true => { bool => 1,
139                                       not  => 'false',
140                                       or   => { qw(
141                                                 true  true
142                                                 false true
143                                         ) },
144                                       and   => { qw(
145                                                  true  true
146                                                  false false
147                                          ) } } ,
148
149                             false => { bool => 0,
150                                        not  => 'true',
151                                        or   => { qw(
152                                                  false false
153                                                  true  true
154                                          ) },
155                                        and  => { qw(
156                                                    ftrue false
157                                                    false false
158                                          ) } },
159
160                            }});
161
162has default => ( is      => 'rw',
163                 isa     => 'Str',
164                 default => 'false');
165
166has or_default => ( is      => 'rw',
167                    isa     => 'Str',
168                    default => 'false' );
169
170has and_default => ( is      => 'rw',
171                     isa     => 'Str',
172                     default => 'true' );
173
174around $_ => sub{
175    my $orig = shift;
176    my $self = shift;
177    $orig->( $self ,  "" . shift ) if @_;
178    $self->sym($orig->($self));
179  } foreach qw( default or_default and_default );
180
181
182=pod
183
184=head2 Accessing and defining to an individual rule.
185
186=over 4
187
188=item C<rule>
189
190The C<rule> method defines new symbol and its  rules.
191
192The first argument of this method is the symbol name.
193
194If called only with a name which is already defined,
195it will return the defined rule as reference to its HASH dictionary.
196
197If called with three or more arguments,
198this method will define a new symbol and its rule.
199
200
201=back
202
203=cut
204
205sub rule {
206  my $self  = shift;
207  my $sym   = shift;
208  my $rules = $self->rules;
209  unless (@_) {
210    $sym = $self->sym("$sym");
211    return exists $rules->{$sym} ? $rules->{$sym} : {};
212  }
213
214  my %o = @_;
215
216  my $rule = $rules->{$sym} = {};
217
218  $rule->{bool} = delete $o{bool} if exists $o{bool};
219  $rule->{not}  = "".$self->sym( delete $o{not} ) if exists $o{not};
220
221  foreach my $op ( qw( or and nor nand xor ) ) {
222    my $spec = delete $o{$op};
223    next unless defined $spec;
224    unless ( isa $spec , 'HASH' ){
225      $rule->{$op} = 0;
226      next;
227    }
228    my $slot = $rule->{$op} = {};
229    while( my( $v , $r ) = each %$spec ) {
230      if( $v =~ s/^-// ){
231        (($rule->{$self->sym($v)} ||= {})->{$op} ||= {})->{$sym} =
232          "". $self->sym($r);
233      }
234      else {
235        $slot->{$self->sym($v)} = "".$self->sym($r);
236      }
237    }
238  }
239}
240
241=pod
242
243=head2 Access to a symbol and its data.
244
245=over 4
246
247=item C<sym>
248
249Returns the symbol whose name is the first argument.
250
251=item C<syms>
252
253Returns all symbols that are defined.
254
255=item C<as_bool>
256
257Returns the value returned when evaluating in logical context.
258
259=back
260
261=cut
262
263
264sub sym {
265  my ($self, $name) = @_;
266  my $rule = $self->rules->{$name};
267  confess "unknown symbol : $name" unless defined $rule;
268  return $rule->{value} if exists $self->{value};
269  $rule->{value} = bless [ $self, $name ],  'Class::Logic::Symbol'
270}
271
272
273sub syms {
274  my $self = shift;
275  map { $self->sym($_) } keys %{$self->rules}
276}
277
278sub as_bool {
279  my ( $self, $v ) = @_;
280  my $rule = $self->rule($v);
281  return $rule->{bool} if exists $rule->{bool};
282  $_[1] = $self->default;
283  goto \&as_bool;
284}
285
286=pod
287
288=head2 Calculator methods.
289
290=head2 C<not>
291
292Returns symbol for the result of "not" calculation.
293
294=head2 C<calc>
295
296Returns the result of evaluating the expression given in the first parameter,
297with the following parameters as its arguments.
298
299=cut
300
301sub not {
302  my ($self, $v) = @_;
303  my $rule = $self->rule($v);
304
305  return exists $rule->{not} ? $self->sym($rule->{not}) : $self->default;
306}
307
308{
309  my %dispatch =
310    (
311
312     xor => sub{
313       my ($self, $a, $b) = @_;
314       $self->calc( or =>  $self->calc( and => $self->not( $a ) , $b ) ,
315                           $self->calc( and => $a , $self->not( $b ) ) )
316     },
317
318     nand => sub{
319       my ($self, $a, $b) = @_;
320       $self->calc( not => $self->calc( and => $a, $b ));
321     },
322
323     nor  => sub{
324       my ($self, $a, $b) = @_;
325       $self->calc( not => $self->calc( or => $a , $b ));
326     },
327
328    );
329
330  while( my ($k, $v) = each %dispatch ){
331    $dispatch{$k} = subname "dispatch--".$k => $v;
332  }
333
334
335  sub calc {
336
337    my ( $self, $op, $a, $b ) = @_;
338
339    return  $self->not( $a ) if $op eq 'not' ;
340
341    my $a_rule = $self->rule($a)->{$op};
342    if ( defined $a_rule ) {
343      confess "$a->$op is not supported" unless isa $a_rule, 'HASH';
344      return $self->sym($a_rule->{$b})   if exists $a_rule->{$b};
345    }
346
347    my $b_rule = $self->rule($b)->{$op};
348    if ( defined $b_rule ) {
349      confess "$b->$op is not supported" unless  isa $b_rule, 'HASH' ;
350      return $self->sym($b_rule->{$a})   if exists $b_rule->{$a};
351    }
352
353    return $dispatch{$op}->( $self, $a, $b )
354      if !$a_rule && !$b_rule && exists $dispatch{$op};
355
356    $self->default;
357
358  }
359}
360
361
362=pod
363
364=head2 Building symbol exporter.
365
366=over 4
367
368=item C<build_exporter>
369
370The C<build_exporter> method generates and returns the reference to a
371subroutine which exports calculation and (pseudo) constant methods
372for all defined symbols.
373
374Generally, this method is used when the module is used as module builder.
375
376=back
377
378=cut
379
380sub build_exporter{
381
382  my $self = shift;
383
384  my $or = do{
385    my $iter;
386    $iter = sub{
387      return $_[0] if 1 == scalar @_ ;
388      my $first  = shift;
389      my $second = shift;
390      unshift @_, $self->sym($first)->or($second);
391      goto $iter;
392    };
393    sub{ $iter->($self->or_default, @_) };
394  };
395
396  my $and = do{
397    my $iter;
398    $iter = sub{
399      return shift if 1 == scalar @_ ;
400      my $first  = shift;
401      my $second = shift;
402      unshift @_, $self->sym($first)->and($second);
403      goto $iter;
404    };
405    sub{ $iter->($self->and_default, @_) };
406  };
407
408  my %exp = (
409             NOT  => sub($) { $self->not(@_) },
410             OR   => $or,
411             AND  => $and,
412             NOR  => sub { $or->(@_)->not },
413             NAND => sub { $and->(@_)->not },
414             XOR  => sub($$) { $self->calc( xor => ( @_ ) ) },
415            );
416  do{
417    $exp{$_} = do{ my $sym = $self->sym($_); sub() { $sym } };
418  } foreach  $self->syms;
419
420  do{
421    my $name = $_;
422    my $sub  = subname $self->name . "::$name" => $exp{$_};
423    $exp{$name} = sub{ $sub };
424  } foreach keys %exp;
425
426  Sub::Exporter::build_exporter({ exports => \%exp,
427                                  groups  => { default => [':all'] }});
428
429}
430
431=pod
432
433=head1 Interfaces of C<Class::Logic::Symbol> Object
434
435=over 4
436
437=item C<not> , C<or>, C<and> , C<xor> , C<nor> , C<nand>
438
439These methods return the symbol for the result of its calculation
440'not' needs no argument; other methods need an argument which
441is a String or a C<Class::Logic::Symbol> object.
442
443=item C<bool>
444
445Returns the value of result of "as_bool" method.
446
447=item C<name>
448
449Returns a name of the symbol.
450
451=back
452
453=cut
454
455{
456  package Class::Logic::Symbol;
457  use Moose;
458  use Sub::Install;
459  our $VERSION = $Class::Logic::VERSION;
460  use overload bool => \&bool , '""' => \&name;
461  Sub::Install::install_sub
462      {
463       into => __PACKAGE__,
464       as   => $_,
465       code => do{
466         my $meth = $_;
467         sub{
468           my $self = shift;
469           $self->[0]->calc( $meth , $self,  @_ );
470         };
471       }
472      } foreach qw( and or not xor nor nand );
473
474  sub bool { my $self = shift;  $self->[0]->as_bool($self) }
475  sub rule { shift->[0] }
476  sub name { shift->[1] }
477}
478
479=pod
480
481=head1 Use as module generator
482
483If user gives an argument "-define" to import method,
484C<Class::Logic> exports the following subroutines:
485
486=over 4
487
488=item C<calculator>
489
490Returnes a calculator which is bound with your module.
491
492=item C<true> , C<false>
493
494Returnes symbols for 'true' and 'false'.
495
496=item C<rule> , C<default> , C<or_default>  , C<and_default>
497
498Same as methods in a C<Class::Logic> object.
499
500However, these subroutines are callable as normal procedure
501and they don't need to specify any object as receiver.
502
503=back
504
505=cut
506
507sub import {
508
509  my $self = shift;
510  return unless @_;
511
512  my $opt = shift;
513  confess "$opt is not supported" unless $opt eq '-define';
514
515  my ( $pkg ) = caller;
516
517  $self = $self->new( name => $pkg );
518  my $true    = $self->sym('true');
519  my $false   = $self->sym('false');
520  my %exports =
521    (
522     calculator => sub() { $self  } ,
523     true       => sub() { $true  },
524     false      => sub() { $false },
525
526     rule       => sub{
527       my $name = shift;
528       $self->rule( $name => @_ );
529     },
530
531     default     => sub{ $self->default( @_ );    },
532     or_default  => sub{ $self->or_default( @_ ); },
533     and_default => sub{ $self->and_default( @_ );},
534     import      => sub{ goto $self->build_exporter; },
535    );
536
537  $exports{$_} = do{
538    my $name = $_;
539    my $sub  = subname __PACKAGE__."->$_" => $exports{$_};
540    sub{ $sub }
541  } foreach keys %exports;
542
543  my $exporter = subname import => Sub::Exporter::build_exporter(
544      {
545       exports => \%exports,
546       groups  => [
547                   default => [qw(:all)],
548                  ],
549      }
550  );
551  goto $exporter;
552}
553
554=pod
555
556=head1 Using Defined module
557
558=over 4
559
560=item C<NOT> , C<AND> , C<OR> , C<NAND> , C<NOR> , C<XOR>
561
562These subroutines return symbols for the result calculated by a
563defined calculator.
564
565The number of arguments each subroutine takes is as follows:
566NOT takes one
567AND, NAND, OR, and NOR take zero or many
568XOR takes two
569
570=item C<true>, C<false> ... and other symbols
571
572A module defined by this module exports (pseudo) constant subroutines
573which(that) return(s) defined symbols.
574
575=back
576
577=cut
578
5791;
580
581__END__
582
583=pod
584
585=head1 SEE ALSO
586
587=over 4
588
589=item L<Math::Logic>
590
591=back
592
593=head1 AUTHOR
594
595lieutar, E<lt>lieutar@1dk.jpE<gt>
596
597=head1 COPYRIGHT AND LICENSE
598
599Copyright (C) 2008 by lieutar
600
601This library is free software; you can redistribute it and/or modify
602it under the same terms as Perl itself, either Perl version 5.10.0 or,
603at your option, any later version of Perl 5 you may have available.
604
605=cut
Note: See TracBrowser for help on using the browser.