File Coverage

blib/lib/Schedule/Activity.pm

Criterion	Covered	Total	%
statement	562	606	92.7
branch	173	220	78.6
condition	88	136	64.7
subroutine	30	30	100.0
pod	0	11	0.0
total	853	1003	85.0

package Schedule::Activity;

use strict;
use warnings;
use List::Util qw/any/;
use Ref::Util qw/is_arrayref is_hashref is_plain_hashref is_ref/;
use Scalar::Util qw/blessed/;
use Schedule::Activity::Annotation;
use Schedule::Activity::Attributes;
use Schedule::Activity::Message;
use Schedule::Activity::Node;
use Schedule::Activity::NodeFilter;

our $VERSION='0.3.0';

sub new {
	my ($ref,%opt)=@_;
	my $class=is_ref($ref)||$ref;
	my %self=(
		config  =>$opt{configuration}//{},
		attr    =>undef,
		valid   =>0,
		built   =>undef,
		reach   =>undef,
		unsafe  =>$opt{unsafe}//0,
		PNA     =>undef, # per node attribute prefix, loaded via config
	);
	return bless(\%self,$class);
}

# validate()
# compile()
# schedule(activities=>[...])

sub _attr {
	my ($self)=@_;
	$$self{attr}//=Schedule::Activity::Attributes->new();
	return $$self{attr};
}

sub validate {
	my ($self,$force)=@_;
	if($$self{valid}&&!$force) { return }
	$$self{config}//={}; if(!is_hashref($$self{config})) { return ('Configuration must be a hash') }
	my @errors=$self->_validateConfig();
	if(!@errors) { $$self{valid}=1 }
	return @errors;
}

sub _validateConfig {
	my ($self)=@_;
	my $attr=$self->_attr();
	my %config=%{$$self{config}};
	my (@errors,@invalids);
	if(!is_hashref($config{node})) { push @errors,'Config is missing:  node'; $config{node}={} }
	if($config{attributes}) {
		if(!is_hashref($config{attributes})) { push @errors,'Attributes invalid structure' }
		else { while(my ($k,$v)=each %{$config{attributes}}) { push @errors,$attr->register($k,%$v) } }
	}
	if($config{messages}) {
		if(!is_hashref($config{messages})) { push @errors,'Messages invalid structure' }
		else {
		while(my ($namea,$msga)=each %{$config{messages}}) {
			if(!is_hashref($msga)) { push @errors,"Messages $namea invalid structure"; next }
			elsif(defined($$msga{attributes})&&!is_hashref($$msga{attributes})) { push @errors,"Messages $namea invalid attributes"; delete($$msga{attributes}) }
			else { foreach my $kv (Schedule::Activity::Message::attributesFromConf($msga)) { push @errors,$attr->register($$kv[0],%{$$kv[1]}) } }
			if(is_hashref($$msga{message})) {
				if(defined($$msga{message}{alternates})&&!is_arrayref($$msga{message}{alternates})) { push @errors,"Messages $namea invalid alternates" }
				else { foreach my $kv (Schedule::Activity::Message::attributesFromConf($$msga{message})) { push @errors,$attr->register($$kv[0],%{$$kv[1]}) } }
			}
		}
	} } # messages
	while(my ($k,$node)=each %{$config{node}}) {
		if(!is_hashref($node)) { push @errors,"Node $k, Invalid structure"; next }
		Schedule::Activity::Node::defaulting($node);
		my @nerrors=Schedule::Activity::Node::validate(%$node);
		if($$node{attributes}) {
			if(!is_hashref($$node{attributes})) { push @nerrors,"attributes, Invalid structure" }
			else { while(my ($k,$v)=each %{$$node{attributes}}) { push @nerrors,$attr->register($k,%$v) } }
		}
		push @nerrors,Schedule::Activity::Message::validate($$node{message},names=>$config{messages});
		foreach my $kv (Schedule::Activity::Message::attributesFromConf($$node{message})) { push @nerrors,$attr->register($$kv[0],%{$$kv[1]}) }
		if(@nerrors) { push @errors,map {"Node $k, $_"} @nerrors; next }
		@invalids=grep {!defined($config{node}{$_})} Schedule::Activity::Node->nextnames(0,$$node{next}//[]);
		if(@invalids) { push @errors,"Node $k, Undefined name in array:  next" }
		if(defined($$node{finish})&&!defined($config{node}{$$node{finish}})) { push @errors,"Node $k, Undefined name:  finish" }
	}
	$config{annotations}//={};
	if(!is_hashref($config{annotations})) { push @errors,'Annotations must be a hash' }
	else { while(my ($k,$notes)=each %{$config{annotations}}) {
		push @errors,map {"Annotation $k:  $_"} map {(
			Schedule::Activity::Annotation::validate(%$_),
			Schedule::Activity::Message::validate($$_{message},names=>$config{messages})
			)} @$notes } }
	return @errors;
}

sub _reachability {
	my ($self)=@_;
	my $changed;
	my %reach=(min=>{},max=>{});
	foreach my $namea (keys %{$$self{built}{node}}) {
		my $nodea=$$self{built}{node}{$namea};
		my @nodes;
		if  (is_arrayref($$nodea{next})) { @nodes=@{$$nodea{next}} }
		elsif(is_hashref($$nodea{next})) { @nodes=map {$$_{node}} values %{$$nodea{next}} }
		foreach my $nodeb (@nodes) {
			$reach{min}{$nodea}{$nodeb}=$$nodea{tmmin};
			$reach{max}{$nodea}{$nodeb}=(($nodea eq $nodeb)?'+':$$nodea{tmmax});
		}
	}
	$changed=1;
	while($changed) { $changed=0;
		foreach my $nodea (keys %{$reach{min}}) {
		foreach my $nodeb (keys %{$reach{min}{$nodea}}) {
		foreach my $nodec (keys %{$reach{min}{$nodeb}}) {
			my $x=$reach{min}{$nodea}{$nodec};
			my $y=$reach{min}{$nodea}{$nodeb}+$reach{min}{$nodeb}{$nodec};
			if(!defined($x)||($x>$y)) {
				$reach{min}{$nodea}{$nodec}=$y;
				$changed=1;
			}
		} } }
	}
	my $triadd=sub {
		my ($x,$y)=@_;
		if($x eq '+') { return '+' }
		if($y eq '+') { return '+' }
		return $x+$y;
	};
	$changed=1;
	while($changed) { $changed=0;
		foreach my $nodea (keys %{$reach{max}}) {
		foreach my $nodeb (keys %{$reach{max}{$nodea}}) {
		foreach my $nodec (keys %{$reach{max}{$nodeb}}) {
			if($nodea eq $nodec) { $reach{max}{$nodea}{$nodec}='+'; next }
			my $x=$reach{max}{$nodea}{$nodec};
			if(defined($x)&&($x eq '+')) { next }
			my $y=&$triadd($reach{max}{$nodea}{$nodeb},$reach{max}{$nodeb}{$nodec});
			if(!defined($x)||($y eq '+')||($x<$y)) {
				$reach{max}{$nodea}{$nodec}=$y;
				$changed=1;
			}
		} } }
	}
	$$self{reach}=\%reach;
	return $self;
}

# These checks ignore any filtering that might be active during construction; these are only sanity checks.
# Recommend stashing the reachability results in $self for later.
#
# Here are the tests and their defined orders.
# 1.  Activity that cannot reach finish
# 2.  Orphaned actions (no activity reaches them)
# 3.  Dual-parent action nodes (with more than a single root activity)  NOT(item2)
# 4.  Dual-finish action nodes  NOT(item3)
# 5.  Dangling actions (cannot reach their finish node)  NOT(item1||item4)
# 6.  Action nodes with tmavg=0  NOT(activity|finish) (this is only a problem if there's a cycle)
#
sub safetyChecks {
	my ($self)=@_;
	my (@errors,$changed);
	$self->_reachability();
	my %reach=%{$$self{reach}};
	#
	# Be very cautious about names versus stringified references.
	my $builtNode=$$self{built}{node};
	my %activities=map {$$builtNode{$_}=>$$builtNode{$_}{finish}} grep {defined($$builtNode{$_}{finish})} keys(%$builtNode);
	my %finishes=map {$_=>1} values(%activities);
	my %actions=map {$_=>$$builtNode{$_}} grep {!exists($activities{$$builtNode{$_}})&&!exists($finishes{$$builtNode{$_}})} keys(%$builtNode);
	my %incompleteActivities=map {$_=>1} grep{!defined($reach{min}{$$builtNode{$_}}{$activities{$$builtNode{$_}}})} grep {defined($$builtNode{$_}{finish})} keys(%$builtNode);
	#
	push @errors,map {"Finish for activity $_ is unreachable"} keys(%incompleteActivities);
	#
	my (%orphans,%dualParent,%dualFinish,%dangling,%infiniteCycle);
	foreach my $action (keys %actions) {
		my $parents=0;
		my $terminals=0;
		foreach my $activity (keys %activities) { if(defined($reach{min}{$activity}{$actions{$action}})) { $parents++ } }
		foreach my $finish   (keys %finishes)   { if(defined($reach{min}{$actions{$action}}{$finish}))   { $terminals++ } }
		if($parents==0)    { $orphans{$action}=1 }
		elsif($parents>1)  { $dualParent{$action}=1 }
		if($terminals>1)   { $dualFinish{$action}=1 }
		elsif(!$terminals) { $dangling{$action}=1 }
		if(($actions{$action}{tmavg}==0)&&(defined($reach{min}{$actions{$action}}{$actions{$action}}))) { $infiniteCycle{$action}=1 }
	}
	push @errors,map {"Action $_ belongs to no activity"} keys(%orphans);
	push @errors,map {"Action $_ belongs to multiple activities"} keys(%dualParent);
	push @errors,map {"Action $_ reaches multiple finish nodes"} keys(%dualFinish);
	push @errors,map {"Dangling action $_"} keys(%dangling);
	push @errors,map {"No progress will be made for action $_"} keys(%infiniteCycle);
	return @errors;
}

sub _buildConfig {
	my ($self)=@_;
	my %base=%{$$self{config}};
	my $attr=$self->_attr();
	my %res;
	if($base{PNA}) { $$self{PNA}=$base{PNA} }
	while(my ($k,$node)=each %{$base{node}}) {
		if(is_plain_hashref($node)) { $res{node}{$k}=Schedule::Activity::Node->new(%$node) }
		elsif(blessed($node))       { $res{node}{$k}=$node }
		else                        { die "Invalid node $k when building config" }
		$res{node}{$k}{keyname}=$k;
		if($$self{PNA}) {
			$res{node}{$k}{attributes}{"$$self{PNA}$k"}={incr=>1};
			$attr->register("$$self{PNA}$k",type=>'int',value=>0);
		}
	}
	my $msgNames=$base{messages}//{};
	while(my ($k,$node)=each %{$res{node}}) {
		$node->nextremap($res{node});
		if(defined($$node{finish})) { $$node{finish}=$res{node}{$$node{finish}} }
		$$node{msg}=Schedule::Activity::Message->new(message=>$$node{message},names=>$msgNames);
		if(is_plain_hashref($$node{require})) { $$node{require}=Schedule::Activity::NodeFilter->new(%{$$node{require}}) }
	}
	$$self{built}=\%res;
	return $self;
}

sub compile {
	my ($self,%opt)=@_;
	if($$self{built}) { return }
	my @errors=$self->validate();
	if(@errors) { return (error=>\@errors) }
	$self->_buildConfig();
	if(!$opt{unsafe}) { @errors=$self->safetyChecks(); if(@errors) { return (error=>\@errors) } }
	return;
}

sub _nodeMessage {
	my ($optattr,$tm,$node)=@_;
	my ($message,$msg)=$$node{msg}->random();
	if($$node{attributes}) {
		while(my ($k,$v)=each %{$$node{attributes}}) {
			$optattr->change($k,%$v,tm=>$tm) } }
	if(is_hashref($msg)) { while(my ($k,$v)=each %{$$msg{attributes}}) {
		$optattr->change($k,%$v,tm=>$tm);
	} }
	#
	return Schedule::Activity::Message->new(message=>$message,attributes=>$$msg{attributes}//{});
}

sub findpath {
	my (%opt)=@_;
	my ($tm,$slack,$buffer,@res)=(0,0,0);
	my %tension=(
		slack =>1-($opt{tensionslack} //$opt{tension}//0.5),
		buffer=>1-($opt{tensionbuffer}//$opt{tension}//0.85659008),
	);
	foreach my $k (qw/slack buffer/) { if($tension{$k}>1){$tension{$k}=1}; if($tension{$k}<0){$tension{$k}=0} }
	my ($node,$conclusion)=($opt{start},$opt{finish});
	$opt{attr}->push();
	while($node&&($node ne $conclusion)) {
		push @res,[$tm,$node];
		push @{$res[-1]},_nodeMessage($opt{attr},$tm+$opt{tmoffset},$node);
		$node->increment(\$tm,\$slack,\$buffer);
		$opt{attr}->push();
		$opt{attr}->log($tm);
		if($tm-$tension{slack}*$slack+rand($tension{buffer}*$buffer+$tension{slack}*$slack)<=$opt{goal}) {
			$node=$node->nextrandom(not=>$conclusion,tm=>$tm,attr=>$opt{attr}{attr})//$node->nextrandom(tm=>$tm,attr=>$opt{attr}{attr}) }
		elsif($node->hasnext($conclusion)) { $node=$conclusion }
		else { $node=$node->nextrandom(not=>$conclusion,tm=>$tm,attr=>$opt{attr}{attr})//$node->nextrandom(tm=>$tm,attr=>$opt{attr}{attr}) }
		$opt{attr}->pop();
	}
	if($node&&($node eq $conclusion)) {
		push @res,[$tm,$conclusion];
		push @{$res[-1]},_nodeMessage($opt{attr},$tm+$opt{tmoffset},$conclusion);
		$conclusion->increment(\$tm,\$slack,\$buffer);
		$node=undef;
	}
	$opt{attr}->pop();
	return (
		steps =>\@res,
		tm    =>$tm,
		slack =>$slack,
		buffer=>$buffer,
	);
}

sub scheduler {
	my (%opt)=@_; # goal,node,config
	if(!is_hashref($opt{node}))      { die 'scheduler called with invalid node' }
	if(!defined($opt{node}{finish})) { die 'scheduler called with non-activity node' }
	$opt{retries}//=10; $opt{retries}--;
	if($opt{retries}<0) { die $opt{error}//'scheduling retries exhausted' }
	#
	my %path=findpath(
		start     =>$opt{node},
		finish    =>$opt{node}{finish},
		goal      =>$opt{goal},
		retries   =>$opt{retries},
		backtracks=>2*$opt{retries},
		attr      =>$opt{attr},
		tmoffset  =>$opt{tmoffset},
		tensionslack =>$opt{tensionslack} //$opt{tension},
		tensionbuffer=>$opt{tensionbuffer}//$opt{tension},
	);
	if($path{retry}) { return scheduler(%opt,retries=>$opt{retries},error=>$path{error}//'Retries exhausted') }
	my @res=@{$path{steps}};
	my ($tm,$slack,$buffer)=@path{qw/tm slack buffer/};
	if($res[-1][1] ne $opt{node}{finish}) { return scheduler(%opt,retries=>$opt{retries},error=>q|Didn't reach finish node|) }
	#
	my $excess=$tm-$opt{goal};
	if(abs($excess)>0.5) {
		if(($excess>0)&&($excess>$slack))   { return scheduler(%opt,retries=>$opt{retries},error=>"Excess exceeds slack ($excess>$slack)") }
		if(($excess<0)&&(-$excess>$buffer)) { return scheduler(%opt,retries=>$opt{retries},error=>'Shortage exceeds buffer ('.(-$excess).">$buffer)") }
		my ($reduction,$rate)=(0);
		if($excess>0) { $rate=$excess/$slack }
		else          { $rate=$excess/$buffer }
		foreach my $entry (@res[0..$#res]) {
			$$entry[0]=$$entry[0]-$reduction;
			my $dt;
			if($excess>0) { $dt=$rate*($$entry[1]->slack()) }
			else          { $dt=$rate*($$entry[1]->buffer()) }
			$reduction+=$dt;
		}
	}
	foreach my $i (0..$#res) {
		my $dt;
		if($i<$#res) { $dt=$res[$i+1][0]-$res[$i][0] }
		else         { $dt=$opt{goal}-$res[$i][0] }
		$res[$i][3]=$res[$i][4]=0;
		$dt-=$res[$i][1]{tmavg}//0;
		if($dt>0) { $res[$i][4]=$dt }
		else      { $res[$i][3]=-$dt }
	}
	#
	# Message selection occurs in _nodeMessage during path construction.
	# Message attributes apply during path construction to permit node
	# filtering, but final materialization occurs after slack/buffer
	# adjustments have been made.
	#
	# Both nodes and their messages may change attributes, but node
	# attributes are applied first, so message attributes will "win" if
	# both contain 'set' operations.  Documented in "/Precedence".
	#
	foreach my $i (0..$#res) {
		my $node=$res[$i][1];
		if($$node{attributes}) {
			while(my ($k,$v)=each %{$$node{attributes}}) {
				$opt{attr}->change($k,%$v,tm=>$res[$i][0]+$opt{tmoffset}) } }
		my ($message,$msg)=$res[$i][2]->random();
		$res[$i][1]=Schedule::Activity::Node->new(%$node,message=>$message);
		if(is_hashref($msg)) { while(my ($k,$v)=each %{$$msg{attributes}}) {
			$opt{attr}->change($k,%$v,tm=>$res[$i][0]+$opt{tmoffset});
		} }
	}
	return @res;
}

sub goalScheduling {
	my ($self,%opt)=@_;
	my %goal=%{delete($opt{goal})};
	if(!is_hashref($goal{attribute})) { return (error=>'goal{attribute} must be hash') }
	{ my $attr=$self->_attr();
		my %validOp=map {$_=>undef} (qw/min max eq ne/);
		my %valueOp=map {$_=>undef} (qw/eq ne/);
		foreach my $k (keys %{$goal{attribute}}) {
			if(!defined($$attr{attr}{$k})) { return (error=>"goal-requested attribute does not exist:  $k") }
			if(!is_hashref($goal{attribute}{$k}))  { return (error=>"goal attribute $k must be a hash") }
			if(!defined($goal{attribute}{$k}{op})) { return (error=>"missing operator in goal $k") }
			if(!exists($validOp{$goal{attribute}{$k}{op}//''})) { return (error=>"invalid operator in goal $k") }
			if(exists($valueOp{$goal{attribute}{$k}{op}})&&!defined($goal{attribute}{$k}{value})) { return (error=>"missing value in goal $k") }
		}
	}
	my $cycles=$goal{cycles}//10;
	my %schedule;
	eval { %schedule=$self->schedule(%opt) };
	my ($bestscore,%best);
	my $notemerge=sub {
		if(!defined($schedule{annotations})) { return }
		my %seen;
		my @activities=@{$schedule{activities}};
		foreach my $group (sort {$a cmp $b} keys(%{$schedule{annotations}})) {
			if($seen{$group}) { next }
			if(!defined($schedule{annotations}{$group})) { next }
			push @activities,@{$schedule{annotations}{$group}{events}};
			$seen{$group}=1;
		}
		if(%seen) {
			@activities=sort {$$a[0]<=>$$b[0]} @activities;
			%{$schedule{attributes}}=$self->computeAttributes(@activities);
		}
	};
	my $score=sub {
		my $res=-1e6;
		if(!defined($schedule{attributes})) { return $res }
		$res=0;
		foreach my $k (keys %{$goal{attribute}}) {
			my %cmp=%{$goal{attribute}{$k}};
			my %attr=%{$schedule{attributes}{$k}//{}};
			my $avg;
			if($$self{PNA}&&($k=~/^\Q$$self{PNA}\E/)) { $avg=$attr{y}//0 }
			else                                      { $avg=$attr{avg}//0 }
			my $weight=$cmp{weight}//1;
			if   ($cmp{op} eq 'max') { $res+=$avg*$weight }
			elsif($cmp{op} eq 'min') { $res-=$avg*$weight }
			elsif($cmp{op} eq 'eq')  { $res-=abs($avg-$cmp{value})*$weight }
			elsif($cmp{op} eq 'ne')  { $res+=abs($avg-$cmp{value})*$weight }
			elsif($cmp{op} eq 'XX')  {
				my $xy=$attr{xy}//[];
				foreach my $i (0..$#$xy-1) {
					$res-=($$xy[1+$i][0]-$$xy[$i][0])*abs(0.5*$$xy[$i][1]+0.5*$$xy[1+$i][1]-$cmp{value})
				}
			}
		}
		return $res;
	};
	&$notemerge();
	$bestscore=&$score(); %best=%schedule;
	my $lasterr;
	#
	while(--$cycles) {
		eval { %schedule=$self->schedule(%opt) };
		if($@) { $lasterr=$@; next }
		&$notemerge();
		my $s=&$score();
		if($s>$bestscore) {
			$bestscore=$s;
			%best=%schedule;
		}
	}
	if(!%best&&$lasterr) { die $lasterr }
	return %best;
}

sub incrementalScheduling {
	my ($self,%opt)=@_;
	my $activities=$opt{activities};
	my $i=0;
	my %after=();
	my %schedule;
	while($i<=$#$activities) {
		my $j=$i;
		while(($j<$#$activities)&&(!is_hashref($$activities[$j][2])||!defined($$activities[$j][2]{goal}))) { $j++ }
		my @acts;
		foreach my $activity (@$activities[$i..$j]) {
			push @acts,[@$activity[0,1]];
			if(is_hashref($$activity[2])) { push @{$acts[-1]},{map {$_=>$$activity[2]{$_}} grep {$_ ne 'goal'} keys(%{$$activity[2]})} }
		}
		%schedule=$self->schedule(%opt,%after,activities=>\@acts,goal=>$$activities[$j][2]{goal});
		if($i<$#$activities) { %after=(after=>{%schedule}) }
		$i=1+$j;
	}
	return %schedule;
}

sub schedule {
	my ($self,%opt)=@_;
	my %check=$self->compile(unsafe=>$opt{unsafe}//$$self{unsafe});
	if($check{error})                  { return (error=>$check{error}) }
	if(!is_arrayref($opt{activities})) { return (error=>'Activities must be an array') }
	if(any {is_hashref($$_[2])&&defined($$_[2]{goal})} @{$opt{activities}}) { return $self->incrementalScheduling(%opt) }
	if($opt{goal}&&%{$opt{goal}})      { return $self->goalScheduling(%opt) }
	my $tmoffset=$opt{tmoffset}//0;
	my %res=(stat=>{slack=>0,buffer=>0});
	if($opt{after}) {
		delete($$self{attr});
		my $attr=$self->_attr();
		push @{$$attr{stack}},$opt{after}{_attr};
		$attr->pop();
		$tmoffset=$opt{after}{_tmmax};
		%{$res{stat}}=(%{$res{stat}},%{$opt{after}{stat}});
	}
	$self->_attr()->push();
	foreach my $activity (@{$opt{activities}}) {
		foreach my $entry (scheduler(goal=>$$activity[0],node=>$$self{built}{node}{$$activity[1]},config=>$$self{built},attr=>$self->_attr(),tmoffset=>$tmoffset,tensionslack=>$opt{tensionslack},tensionbuffer=>$opt{tensionbuffer})) {
			push @{$res{activities}},[$$entry[0]+$tmoffset,@$entry[1..$#$entry]];
			$res{stat}{slack}+=$$entry[3]; $res{stat}{buffer}+=$$entry[4];
			$res{stat}{slackttl}+=$$entry[1]{tmavg}-$$entry[1]{tmmin};
			$res{stat}{bufferttl}+=$$entry[1]{tmmax}-$$entry[1]{tmavg};
		}
		$tmoffset+=$$activity[0];
	}
	$self->_attr()->log($tmoffset);
	if($opt{after}) { unshift @{$res{activities}},@{$opt{after}{activities}} }
	%{$res{attributes}}=$self->_attr()->report();
	if(!$opt{nonote}) { while(my ($group,$notes)=each %{$$self{config}{annotations}}) {
		my @schedule;
		foreach my $note (@$notes) {
			my $annotation=Schedule::Activity::Annotation->new(%$note);
			foreach my $note ($annotation->annotate(@{$res{activities}})) {
				my ($message,$mobj)=Schedule::Activity::Message->new(message=>$$note[1]{message},names=>$$self{config}{messages}//{})->random();
				my %node=(%{$mobj//{}},message=>$message);
				if($$note[1]{annotations}) { $node{annotations}=$$note[1]{annotations} }
				push @schedule,[$$note[0],\%node,@$note[2..$#$note]];
			}
		}
		@schedule=sort {$$a[0]<=>$$b[0]} @schedule;
		for(my $i=0;$i<$#schedule;$i++) {  ## no critic (CStyleForLoops)
			if($schedule[$i+1][0]==$schedule[$i][0]) {
				splice(@schedule,$i+1,1); $i-- } }
		$res{annotations}{$group}{events}=\@schedule;
	} }
	$self->_attr()->push(); $res{_attr}=pop(@{$$self{attr}{stack}}); # store a copy in {_attr}
	$self->_attr()->pop();
	$res{_tmmax}=$tmoffset;
	return %res;
}

sub computeAttributes {
	my ($self,@activities)=@_;
	$self->_attr()->push();
	$self->_attr()->reset();
	foreach my $event (sort {$$a[0]<=>$$b[0]} @activities) {
		my ($tm,$node,$msg)=@$event;
		if($$node{attributes}) {
			while(my ($k,$v)=each %{$$node{attributes}}) {
				$self->_attr()->change($k,%$v,tm=>$tm) } }
		if(is_hashref($msg)) { while(my ($k,$v)=each %{$$msg{attributes}}) {
			$self->_attr()->change($k,%$v,tm=>$tm);
		} }
	}
	my %res=$self->_attr()->report();
	$self->_attr()->pop();
	return %res;
}

sub loadMarkdown {
	my ($text)=@_;
	my $list=qr/(?:\d+\.|[-*])/;
	my (%config,@activities,@siblings,$activity,$tm);
	foreach my $line (split(/\n/,$text)) {
		if($line=~/^\s*$/) { next }
		if($line=~/^$list\s*(.*)$/) {
			$activity=$1; $tm=0;
			if($activity=~/(?.*?),\s*(?\d+)(?min|sec)\s*$/) {
				$activity=$+{name}; $tm=$+{tm}; if($+{unit} eq 'min') { $tm*=60 } }
			if(defined($config{node}{$activity})) { die "Name conflict:  $activity" }
			push @activities,[$tm,$activity];
			@siblings=();
			$config{node}{$activity}={
				message=>$activity,
				next=>[],
				tmavg=>0,
				finish=>"$activity, conclude",
			};
			$config{node}{"$activity, conclude"}={tmavg=>0};
		}
		elsif($line=~/^\s+$list\s*(.*)$/) {
			if(!$activity) { die 'Action without activity' }
			my $action=$1; $tm=60;
			if($action=~/(?.*?),\s*(?\d+)(?min|sec)\s*$/) {
				$action=$+{name}; $tm=$+{tm}; if($+{unit} eq 'min') { $tm*=60 } }
			$action="$activity, $action";
			push @{$config{node}{$activity}{next}},$action;
			$activities[-1][0]||=$tm;
			if(defined($config{node}{$action})) { die "Name conflict:  $action" }
			$config{node}{$action}={
				message=>$action,
				next=>[@siblings,"$activity, conclude"],
				tmavg=>$tm,
			};
			foreach my $sibling (@siblings) { push @{$config{node}{$sibling}{next}},$action }
			push @siblings,$action;
		}
	}
	return (configuration=>\%config,activities=>\@activities);
}

1;

__END__