AA.pm

   1 package AA;
   2
   3 use overload '""' => 'ID';
   4
   5 our $PI = 3.1415926535;
   6 our $TWOPI = 2*$PI;
   7
   8 our %known_objs = ( );
   9 our $debug = 1;
  10 our $record_dep_obj;
  11 our $record_dep_attr;
  12 our $record_deps;
  13 our @pending_recalcs;
  14
  15 sub new($$) {
  16         my ($class, $id) = @_;
  17         my $o = {
  18                 ID => $id,
  19         };
  20         !defined $known_objs{$id} or die "Object $id already defined";
  21         $known_objs{$id} = $o;
  22         print "Created object $id\n" if $debug;
  23         return bless $o, $class;
  24 }
  25
  26 sub find($$) {
  27         my ($class, $id) = @_;
  28         defined $known_objs{$id} or die "Object $id not known";
  29         return $known_objs{$id};
  30 }
  31
  32 sub calculate($) {
  33         my ($class) = @_;
  34         my $o;
  35         while ($o = shift @pending_recalcs) {
  36                 print "Going to recalculate object $o\n" if $debug;
  37                 my $pend = $o->{PENDING};
  38                 foreach my $a (keys %$pend) {
  39                         $o->Calc("$a");
  40                 }
  41                 delete $o->{PENDING};
  42         }
  43 }
  44
  45 sub draw($$) {
  46         my ($class, $cairo) = @_;
  47         my @q = ();
  48         print "Redrawing the scene...\n" if $debug;
  49         foreach my $o (values %known_objs) {
  50                 push @q, $o if defined $o->{'a:d'};
  51         }
  52         foreach my $o (sort { $a->{'a:d'} <=> $b->{'a:d'} } @q) {
  53                 print "Drawing $o at depth ", $o->{'a:d'}, "\n" if $debug;
  54                 $o->Draw($cairo);
  55         }
  56 }
  57
  58 sub ID($) {
  59         return (shift @_)->{ID};
  60 }
  61
  62 sub Define($$) {
  63         my ($o, $a) = @_;
  64         !exists $o->{"a:$a"} or die "Redefining attribute $a of object $o";
  65         $o->{"a:$a"} = undef;           # attribute value
  66         # $o->{"f:$a"} = undef;         # binding function
  67         $o->{"d:$a"} = { };             # depends on (obj:attr => obj)
  68         $o->{"n:$a"} = { };             # notify (obj:attr => obj)
  69 }
  70
  71 sub DefSet($$$) {
  72         my ($o, $a, $v) = @_;
  73         $o->Define($a);
  74         $o->Set($a, $v);
  75 }
  76
  77 sub DefBind($$$) {
  78         my ($o, $a, $v) = @_;
  79         $o->Define($a);
  80         $o->Bind($a, $v);
  81 }
  82
  83 sub DefDep($$$$) {
  84         my ($o, $a, $v, $b) = @_;
  85         $o->Define($a);
  86         $o->Bind($a, sub { $v->Get($b); });
  87 }
  88
  89 sub Exists($$) {
  90         my ($o, $a) = @_;
  91         return defined $o->{"a:$a"};
  92 }
  93
  94 sub Get($$) {
  95         my ($o, $a) = @_;
  96         defined $o->{"a:$a"} or die "Getting undefined attribute $a of object $o";
  97         if ($record_deps) {
  98                 # record the dependency
  99                 my $did = "$o:$a";
 100                 if (!defined $record_deps->{$did}) {
 101                         $record_deps->{$did} = $o;
 102                         my $rid = "$record_dep_obj:$record_dep_attr";
 103                         $o->{"n:$a"}->{$rid} = $record_dep_obj;
 104                         print "Added automatic dependency $rid -> $did\n" if $debug;
 105                 }
 106         }
 107         return $o->{"a:$a"};
 108 }
 109
 110 sub Set($$$) {
 111         my ($o, $a, $v) = @_;
 112         exists $o->{"a:$a"} or die "Setting undefined attribute $a of object $o";
 113         print "Setting $o:$a = $v\n" if $debug;
 114         $o->{"a:$a"} = $v;
 115         !defined $o->{"f:$a"} or $o->UnBind($a);
 116         $o->Notify($a);
 117 }
 118
 119 sub Bind($$$) {
 120         my ($o, $a, $f) = @_;
 121         exists $o->{"a:$a"} or die "Binding undefined attribute $a of object $o";
 122         print "Binding $o:$a\n" if $debug;
 123         $o->UnBind($a);
 124         $o->{"f:$a"} = $f;
 125         $o->Calc($a);
 126 }
 127
 128 sub Calc($$) {
 129         my ($o, $a) = @_;
 130         die if $record_deps;
 131         $record_deps = $o->{"d:$a"};
 132         $record_dep_obj = $o;
 133         $record_dep_attr = $a;
 134
 135         $o->{"a:$a"} = undef;
 136         $o->{"a:$a"} = &{$o->{"f:$a"}} ($o);
 137
 138         $record_deps = undef;
 139         $record_dep_obj = undef;
 140         $record_dep_attr = undef;
 141
 142         print "Recalculated $o:$a = ", $o->{"a:$a"}, "\n" if $debug;
 143         $o->Notify($a);
 144 }
 145
 146 sub UnBind($$) {
 147         my ($o, $a) = @_;
 148         my $aid = "$o:$a";
 149         foreach my $dep (keys %{$o->{"d:$a"}}) {
 150                 my ($deponame, $depa) = split(/:/, $dep);
 151                 my $depo = $o->{"d:$a"}->{$dep};
 152                 delete $depo->{"n:$depa"}->{$aid};
 153                 print "Removed notify $aid -> $depo:$depa\n" if $debug;
 154         }
 155         $o->{"d:$a"} = { };
 156         delete $o->{"f:$a"};
 157 }
 158
 159 sub Notify($$) {
 160         my ($o, $a) = @_;
 161         foreach my $dep (keys %{$o->{"n:$a"}}) {
 162                 my ($deponame, $depa) = split(/:/, $dep);
 163                 my $depo = $o->{"n:$a"}->{$dep};
 164                 print "Sending notify $o:$a -> $deponame:$depa\n" if $debug;
 165                 if (!defined $depo->{PENDING}) {
 166                         $depo->{PENDING} = { };
 167                         push @pending_recalcs, $depo;
 168                         print "\tPending object $deponame\n" if $debug;
 169                 }
 170                 $depo->{PENDING}->{$depa} = 1;
 171         }
 172 }
 173
 174 1;