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 = 0;
  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                 delete $o->{PENDING};
  39                 foreach my $a (keys %$pend) {
  40                         $o->Calc("$a");
  41                 }
  42         }
  43 }
  44
  45 sub get_visible_objects() {
  46         my @q = ();
  47         foreach my $o (values %known_objs) {
  48                 push @q, $o if defined $o->{'a:d'};
  49         }
  50         return sort { $a->{'a:d'} <=> $b->{'a:d'} } @q;
  51 }
  52
  53 sub draw($$) {
  54         my ($class, $cairo) = @_;
  55         print "Redrawing the scene...\n" if $debug;
  56         foreach my $o (get_visible_objects()) {
  57                 print "Drawing $o at depth ", $o->{'a:d'}, "\n" if $debug;
  58                 $o->Draw($cairo);
  59         }
  60 }
  61
  62 sub ID($) {
  63         return (shift @_)->{ID};
  64 }
  65
  66 sub Define($$) {
  67         my ($o, $a) = @_;
  68         !exists $o->{"a:$a"} or die "Redefining attribute $a of object $o";
  69         $o->{"a:$a"} = undef;           # attribute value
  70         # $o->{"f:$a"} = undef;         # binding function
  71         $o->{"d:$a"} = { };             # depends on (obj:attr => obj)
  72         $o->{"n:$a"} = { };             # notify (obj:attr => obj)
  73 }
  74
  75 sub DefSet($$$) {
  76         my ($o, $a, $v) = @_;
  77         $o->Define($a);
  78         $o->Set($a, $v);
  79 }
  80
  81 sub DefBind($$$) {
  82         my ($o, $a, $v) = @_;
  83         $o->Define($a);
  84         $o->Bind($a, $v);
  85 }
  86
  87 sub DefDep($$$$) {
  88         my ($o, $a, $v, $b) = @_;
  89         $o->Define($a);
  90         $o->Bind($a, sub { $v->Get($b); });
  91 }
  92
  93 sub Exists($$) {
  94         my ($o, $a) = @_;
  95         return defined $o->{"a:$a"};
  96 }
  97
  98 sub Get($$) {
  99         my ($o, $a) = @_;
 100         defined $o->{"a:$a"} or die "Getting undefined attribute $a of object $o";
 101         if ($record_deps) {
 102                 # record the dependency
 103                 my $did = "$o:$a";
 104                 if (!defined $record_deps->{$did}) {
 105                         $record_deps->{$did} = $o;
 106                         my $rid = "$record_dep_obj:$record_dep_attr";
 107                         $o->{"n:$a"}->{$rid} = $record_dep_obj;
 108                         print "Added automatic dependency $rid -> $did\n" if $debug;
 109                 }
 110         }
 111         return $o->{"a:$a"};
 112 }
 113
 114 sub Set($$$) {
 115         my ($o, $a, $v) = @_;
 116         exists $o->{"a:$a"} or die "Setting undefined attribute $a of object $o";
 117         print "Setting $o:$a = $v\n" if $debug;
 118         $o->{"a:$a"} = $v;
 119         !defined $o->{"f:$a"} or $o->UnBind($a);
 120         $o->Notify($a);
 121 }
 122
 123 sub Bind($$$) {
 124         my ($o, $a, $f) = @_;
 125         exists $o->{"a:$a"} or die "Binding undefined attribute $a of object $o";
 126         print "Binding $o:$a\n" if $debug;
 127         $o->UnBind($a);
 128         $o->{"f:$a"} = $f;
 129         $o->Calc($a);
 130 }
 131
 132 sub Calc($$) {
 133         my ($o, $a) = @_;
 134         die if $record_deps;
 135         return unless defined $o->{"f:$a"};
 136
 137         $record_deps = $o->{"d:$a"};
 138         $record_dep_obj = $o;
 139         $record_dep_attr = $a;
 140
 141         $o->{"a:$a"} = undef;
 142         $o->{"a:$a"} = &{$o->{"f:$a"}} ($o);
 143
 144         $record_deps = undef;
 145         $record_dep_obj = undef;
 146         $record_dep_attr = undef;
 147
 148         print "Recalculated $o:$a = ", $o->{"a:$a"}, "\n" if $debug;
 149         $o->Notify($a);
 150 }
 151
 152 sub UnBind($$) {
 153         my ($o, $a) = @_;
 154         my $aid = "$o:$a";
 155         foreach my $dep (keys %{$o->{"d:$a"}}) {
 156                 my ($deponame, $depa) = split(/:/, $dep);
 157                 my $depo = $o->{"d:$a"}->{$dep};
 158                 delete $depo->{"n:$depa"}->{$aid};
 159                 print "Removed notify $aid -> $depo:$depa\n" if $debug;
 160         }
 161         $o->{"d:$a"} = { };
 162         delete $o->{"f:$a"};
 163 }
 164
 165 sub Notify($$) {
 166         my ($o, $a) = @_;
 167         foreach my $dep (keys %{$o->{"n:$a"}}) {
 168                 my ($deponame, $depa) = split(/:/, $dep);
 169                 my $depo = $o->{"n:$a"}->{$dep};
 170                 print "Sending notify $o:$a -> $deponame:$depa\n" if $debug;
 171                 if (!defined $depo->{PENDING}) {
 172                         $depo->{PENDING} = { };
 173                         push @pending_recalcs, $depo;
 174                         print "\tPending object $deponame\n" if $debug;
 175                 }
 176                 $depo->{PENDING}->{$depa} = 1;
 177         }
 178 }
 179
 180 sub MultiSet($@) {
 181         my $o = shift @_;
 182         my ($a, $v);
 183         while ($a = shift @_) {
 184                 $v = shift @_;
 185                 if (ref $v eq "CODE") {
 186                         $o->Bind($a, $v);
 187                 } else {
 188                         $o->Set($a, $v);
 189                 }
 190         }
 191 }
 192
 193 sub SetTicker($$$$$) {
 194         my ($o, $a, $x0, $x1, $dt) = @_;
 195         $o->Bind($a, AA::Anim->ticker($x0, $x1, $dt));
 196         AA::Anim->add_timer($dt, sub { $o->Set($a, $x1); });
 197 }
 198
 199 package AA::Scene;
 200
 201 sub new($) {
 202         my ($class) = @_;
 203         my $scene = [];
 204         print "Simulated draw...\n" if $debug;
 205         foreach my $o (AA::get_visible_objects()) {
 206                 print "Drawing $o at depth ", $o->{'a:d'}, "\n" if $debug;
 207                 my $obj = [$o];
 208                 foreach my $k (keys %$o) {
 209                         $k =~ /^a:/ && push @$obj, $k, $o->{$k};
 210                 }
 211                 push @$scene, $obj;
 212         }
 213         return bless($scene, $class);
 214 }
 215
 216 sub Draw($$) {
 217         my ($scene, $cairo) = @_;
 218         foreach my $obj (@$scene) {
 219                 my $o = $obj->[0];
 220                 for (my $i=1; $i<@$obj; $i+=2) {
 221                         my $a =$obj->[$i];
 222                         my $v =$obj->[$i+1];
 223                         $o->{$a} = $v;
 224                 }
 225                 $o->Draw($cairo);
 226         }
 227 }
 228
 229 1;