/*  PS.PL  */


/*
:- module ps.
*/


/*
SPECIFICATION
-------------
*/


/*
IMPLEMENTATION
--------------

bagof not portable.
*/


:- reconsult('$eden_src/outputt').
:- reconsult('$eden_src/control').
:- reconsult('$eden_src/lists').


ps( Time, Rules, Raps, STM0, StopPred, SRP, Context0, STM ) :-
    diagnose( 'PS', 'Starting cycle'...Time<>':'~ ),
    diagnose( 'PS', 'STM is'...stm_(STM0,4)~ ),
    match( Rules, STM0, Matched ),
    diagnose( 'PS', 'Matched rules'...rules_(Matched,4)~ ),
    Matched \= [],
    !,
    resolve( Matched, STM0, SRP, Context0, Resolved ),
    diagnose( 'PS', 'Firing rule'...rules_([Resolved],4)~ ),
    fire( Resolved, Raps, Time, STM0, Context0, STM1, SRP, Context1 ),
    diagnose( 'PS', 'STM is'...stm_(STM1,4)~~ ),
    Time1 is Time + 1,
    ps_continue_if_necessary( Time1, Rules, Raps, STM1, StopPred, SRP, Context1, STM ).

ps( _, _, _, _, _, _, _, _ ) :-
    diagnose( 'PS', 'No rules matched, so exiting'~ ),
    true.
    /* if no rules matched.  */


ps_continue_if_necessary( Time, Rules, Raps, STM, StopPred, SRP, Context, STM ) :-
    (
        StopPred = '$no_goal'(G)
    ->
        not(stm_member( G, STM ))
    ;
        Goal =.. [ StopPred, STM ],
        call( Goal )
    ).

ps_continue_if_necessary( Time, Rules, Raps, STM0, StopPred, SRP, Context, STM ) :-
    ps( Time, Rules, Raps, STM0, StopPred, SRP, Context, STM ).


ps( Rules, Raps, STM0, StopPred, SRP, STM ) :-
    ps( 1, Rules, Raps, STM0, StopPred, SRP, [], STM ).


ps( Rules, STM0, StopPred, SRP, STM ) :-
    ps( 1, Rules, [], STM0, StopPred, SRP, [], STM ).


fire( Rule, Raps, Time, STM0, Context0, STM, SRP, Context ) :-
    rule_vs_action( Rule, Action ),
    fire_all( STM0, Raps, Time, Action, SRP, STM ),
    rule_vs_rule_id( Rule, RuleId ),
    Context = [ fired(RuleId,Time) | Context0 ].


fire_all( STM, _, _, [], _, STM ) :- !.

fire_all( STM0, Raps, Time, [Action1|ActionsN], SRP, STM ) :-
    fire_one( STM0, Raps, Time, Action1, SRP, STM1 ),
    fire_all( STM1, Raps, Time, ActionsN, SRP, STM ).


fire_one( STM0, Raps, Time, Term, Context, STM ) :-
    fire_one_1( STM0, Raps, Time, Term, Context, STM ), !.

fire_one( STM0, Raps, Time, Term, Context, STM ) :-
    bug( 'fire_one: failed', [Term] ).


fire_one_1( STM0, Raps, Time, erase(Term), _, STM1 ) :-
    !,
    stm_delete( STM0, Time, Term, STM1 ).

fire_one_1( STM0, Raps, Time, '$at'(Term), SRP, STM ) :-
    copy( Raps, Raps_ ),
    raps_member( Rap, Raps_ ),
    rap_vs_goal( Rap, '$at'(Term) ),
    !,
    rap_vs_plan( Rap, Plan ),
    diagnose( 'PS', 'Starting RAP'...Rap~ ),
    stm_insert( STM0, Time, Term, STM1 ),
    do_plan( STM1, Raps, Time, Term, Plan, SRP, STM2 ),
    stm_delete( STM2, Time, Term, STM ).

fire_one_1( STM0, Raps, Time, '$at'(Term), _, STM1 ) :-
    !,
    stm_insert( STM0, Time, Term, STM1 ).

fire_one_1( STM, Raps, Time, Term, _, STM ) :-
    !,
    call( Term ).

fire_one_1( STM0, Raps, Time, sub(Name), SRP, STM ) :-
    !,
    '$sub_rules'( Name, Rules ),
    ps( Time, Rules, Raps, STM0, '$finish', SRP, [], STM ).


/*
Matching.
---------
*/


match( Rules, STM, Matched ) :-
    fast_bagof(
            Rule,
            (   rules_member( Rule, Rules ),
                rule_vs_condition( Rule, Cond ),
                match_cond( Cond, STM )
            ),
            Matched
         ).


match_cond( [], _ ) :- !.

match_cond( [C1|CN], STM ) :-
    !,
    match_primitive_cond( C1, STM ),
    match_cond( CN, STM ).


match_primitive_cond( '$at'(Term), STM ) :-
    !,
    stm_member( Term, STM ).

match_primitive_cond( not('$at'(Term)), STM ) :-
    !,
    not(stm_member( Term, STM )).

match_primitive_cond( Term, STM ) :-
    call( Term ).


/*
Conflict resolution.
--------------------
*/


resolve( [], STM, SRP, Context, _ ) :-
    !,
    bug( 'resolve: no rules', [STM,SRP,Context] ).

resolve( [Rule], _, _, _, Rule ) :- !.

resolve( [Rule|_], _, [], _, Rule ) :- !.

resolve( Rules, STM, [s|Rest], Context, Resolved ) :-
    !,
    resolve_by_specificity( Rules, STM, MostSpecific ),
    resolve( MostSpecific, STM, Rest, Context, Resolved ).

resolve( Rules, STM, [r|Rest], Context, Resolved ) :-
    !,
    resolve_by_recency( Rules, STM, Context, LeastRecent ),
    resolve( LeastRecent, STM, Rest, Context, Resolved ).

resolve( Rules, STM, [p|Rest], Context, Resolved ) :-
    !,
    resolve_by_priority( Rules, STM, MostImportant ),
    resolve( MostImportant, STM, Rest, Context, Resolved ).

resolve( Rules, _, SRP, _, _ ) :-
    bug( 'resolve: bad SRP', [SRP] ).


resolve_by_specificity( Rules, STM, MostSpecific ) :-
    tag_by_unspecificity( Rules, TaggedRules ),
    keysort( TaggedRules, Sorted ),
    diagnose( 'PS', 'Sorted by specificity to give rules'~<>tagged_rules_(Sorted,4)~ ),
    untag_and_take_best( Sorted, MostSpecific ).


resolve_by_priority( Rules, STM, MostImportant ) :-
    tag_by_priority( Rules, TaggedRules ),
    keysort( TaggedRules, Sorted ),
    diagnose( 'PS', 'Sorted by priority to give rules'~<>tagged_rules_(Sorted,4)~ ),
    untag_and_take_best( Sorted, MostImportant ).


resolve_by_recency( Rules, STM, Context, LeastRecent ) :-
    tag_by_time( Rules, Context, TaggedRules ),
    keysort( TaggedRules, Sorted ),
    diagnose( 'PS', 'Sorted by recency to give rules'~<>tagged_rules_(Sorted,4)~ ),
    untag_and_take_best( Sorted, LeastRecent ).


tag_by_unspecificity( [], [] ) :- !.

tag_by_unspecificity( [Rule|Rules], [MinusS-Rule|Taggeds] ) :-
    rule_vs_condition( Rule, Cond ),
    conditions_specificity( Cond, S ),
    MinusS is -S,
    !,
    tag_by_unspecificity( Rules, Taggeds ).


conditions_specificity( L, S ) :-
    conditions_specificity( L, 0, 0, S ).


conditions_specificity( [], Sum, Count, S ) :-
    !,
    S is Sum.
    /*  Don't take average.  */

conditions_specificity( [C1|Cn], Sum0, Count0, S ) :-
    condition_specificity( C1, CS ),
    Sum1 is Sum0 + CS,
    Count1 is Count0 + 1,
    conditions_specificity( Cn, Sum1, Count1, S ).


condition_specificity( C1, CS ) :-
    C1 =.. [ _ | Args ],
    args_specificity( Args, AS ),
    CS is AS + 1.


args_specificity( Args, S ) :-
    args_specificity( Args, 0, S ).


args_specificity( [], S, S ) :- !.

args_specificity( [A1|AN], S0, S ) :-
    var(A1),
    !,
    S1 is S0 + 0.5,
    args_specificity( AN, S1, S ).

args_specificity( [A1|AN], S0, S ) :-
    S1 is S0 + 1,
    args_specificity( AN, S1, S ).


tag_by_priority( [], [] ) :- !.

tag_by_priority( [Rule|Rules], [MinusP-Rule|Taggeds] ) :-
    rule_vs_priority( Rule, P ),
    MinusP is -P,
    !,
    tag_by_priority( Rules, Taggeds ).


tag_by_time( [], _, [] ) :- !.

tag_by_time( [Rule|Rules], Context, [Time-Rule|Taggeds] ) :-
    member( fired(RuleId,Time), Context ),
    rule_vs_rule_id( Rule, RuleId ),
    !,
    tag_by_time( Rules, Context, Taggeds ).

tag_by_time( [Rule|Rules], Context, [0-Rule|Taggeds] ) :-
    tag_by_time( Rules, Context, Taggeds ).


untag_and_take_best( [], [] ) :- !.

untag_and_take_best( [K-H1,K-H2|T], [H1|T_] ) :-
    !,
    untag_and_take_best( [K-H2|T], T_ ).

untag_and_take_best( [_-H|_], [H] ).


/*
Plans.
------
*/


do_plan( STM, _, _, _, [], _, STM ) :- !.

do_plan( STM0, Raps, Time, Goal, [A1|An], SRP, STM ) :-
    diagnose( 'PS', 'Doing RAP action'...A1~ ),
    do_a( STM0, Raps, Time, Goal, A1, SRP, STM1 ),
    do_plan( STM1, Raps, Time, Goal, An, SRP, STM ).


do_a( STM0, Raps, Time, Goal, ::(Prec,A), SRP, STM ) :-
    call(Prec),
    !,
    do_a( STM0, Raps, Time, Goal, A, SRP, STM ).

do_a( STM, _, _, _, ::(_,_), _, STM ).

do_a( STM0, Raps, Time, Goal, '$rules'(Rules), SRP, STM ) :-
    ps( Time, Rules, Raps, STM0, '$no_goal'(Goal), SRP, [], STM ).

do_a( STM0, Raps, Time, Goal, '$at'(Term), SRP, STM ) :-
    copy( Raps, Raps_ ),
    raps_member( Rap, Raps_ ),
    rap_vs_goal( Rap, '$at'(Term) ),
    !,
    rap_vs_plan( Rap, Plan ),
    diagnose( 'PS', 'Starting RAP'...Rap~ ),
    stm_insert( STM0, Time, Term, STM1 ),
    do_plan( STM1, Raps, Time, Term, Plan, SRP, STM2 ),
    stm_delete( STM2, Time, Term, STM ).

do_a( STM0, Raps, Time, Goal, '$at'(Term), SRP, STM ) :-
    !,
    stm_insert( STM0, Time, Term, STM ).

do_a( STM0, Raps, Time, Goal, (C->A1;A2), SRP, STM ) :-
    !,
    (
        call(C)
    ->
        do_a( STM0, Raps, Time, Goal, A1, SRP, STM )
    ;
        do_a( STM0, Raps, Time, Goal, A2, SRP, STM )
    ).

do_a( STM, Raps, Time, Goal, A, SRP, STM ) :-
    call( A ).


/*
Rules.
------
*/


rule_vs_action( rule(_,_,Action,_), Action ).


rule_vs_condition( rule(_,Cond,_,_), Cond ).


rule_vs_priority( rule(Priority,_,_,_), Priority ).


rule_vs_rule_id( rule(_,_,_,RuleId), RuleId ).


rules_member( Rule, Rules ) :-
    member( Rule, Rules ).


rule_insert( Rules, Rule, [Rule|Rules] ).


:- assert( '$rule_id'(0) ).


new_rule( rule(_,_,_,RuleId) ) :-
    '$rule_id'(RuleId),
    retract( '$rule_id'(_) ),
    Next is RuleId + 1,
    assert( '$rule_id'(Next) ).


/*
Subs.
-----
*/


sub_vs_plan( sub(_,Plan), Plan ).


sub_vs_goal( sub(Goal,_), Goal ).


subs_member( Sub, Subs ) :-
    member( Sub, Subs ).


sub_insert( Subs, Sub, [Sub|Subs] ).


/*
Raps.
-----
*/


rap_vs_plan( rap(_,Plan), Plan ).


rap_vs_goal( rap(Goal,_), Goal ).


raps_member( Rap, Raps ) :-
    member( Rap, Raps ).


rap_insert( Raps, Rap, [Rap|Raps] ).


/*
STM.
----
*/


new_stm( 'stm'(0,0,[]) ).


stm_insert( 'stm'(LastTime,LastTag,Facts0), Time, Term, 'stm'(Time,Tag,Facts) ) :-
    (
        LastTime = Time
    ->
        Tag is LastTag + 1
    ;
        Tag = 1
    ),
    TimeStamp is Time*1000 + Tag,
    Facts = [ fact(Term,TimeStamp) | Facts0 ].


stm_delete( 'stm'(LastTime,LastTag,Facts0), Time, Term, 'stm'(Time,Tag,Facts) ) :-
    (
        LastTime = Time
    ->
        Tag is LastTag + 1
    ;
        Tag = 1
    ),
    delete( Facts0, fact(Term,_), Facts ).
    /*  Variables in Term must remain unbound. This is ensured by
        'delete'.
    */


stm_member( Term, TimeStamp, 'stm'(_,_,Facts) ) :-
    member( fact(Term,TimeStamp), Facts ).


stm_member( Term, 'stm'(_,_,Facts) ) :-
    stm_member( Term, TimeStamp, 'stm'(_,_,Facts) ).


show_stm( STM, Indent ) :-
    forall(
        stm_member( Term, TimeStamp, STM ),
        output( spaces_(Indent)<>Term...'('<>timestamp_(TimeStamp)<>')'~ )
    ).


list_to_stm( L, STM ) :-
    new_stm( STM0 ),
    list_to_stm( L, STM0, STM ).


list_to_stm( [], STM, STM ) :- !.

list_to_stm( [Term|Terms], STM0, STM ) :-
    stm_insert( STM0, 0, Term, STM1 ),
    list_to_stm( Terms, STM1, STM ).


/*
Output.
-------
*/


:- add_user_output( ps_output ).


ps_output( timestamp_(T) ) :-
    !,
    Time is T div 1000,
    Tag is T mod 1000,
    output( Time<>'.'<>Tag ).

ps_output( stm_(STM,Indent) ) :-
    !,
    show_stm(STM,Indent).

ps_output( rules_(Rules,_) ) :-
    !,
    show_rules( Rules ).

ps_output( tagged_rules_(Rules,_) ) :-
    !,
    show_tagged_rules( Rules ).

ps_output( cond_(C) ) :-
    !,
    show_cond(C).

ps_output( action_(C) ) :-
    !,
    show_action(C).

ps_output( simple_ac_(AC) ) :-
    !,
    show_simple_ac(AC).


show_rules( [] ) :- !.

show_rules( [R1|Rn] ) :-
    show_rule( R1 ),
    ( Rn \= [] -> output(nl_), show_rules( Rn ) ; true ).


show_rule( Rule ) :-
    rule_vs_condition( Rule, C ),
    rule_vs_action( Rule, A ),
    output( cond_(C)...'=>'...action_(A) ).


show_tagged_rules( [] ) :- !.

show_tagged_rules( [R1|Rn] ) :-
    show_tagged_rule( R1 ),
    ( Rn \= [] -> output(nl_), show_tagged_rules( Rn ) ; true ).


show_tagged_rule( Tag-Rule ) :-
    rule_vs_condition( Rule, C ),
    rule_vs_action( Rule, A ),
    output( Tag...cond_(C)...'=>'...action_(A) ).


show_cond( C ) :-
    output( seplist_(C,',',Elt,simple_ac_(Elt)) ).


show_action( A ) :-
    output( seplist_(A,',',Elt,simple_ac_(Elt)) ).


show_simple_ac( '$at'(A) ) :-
    !,
    output( '@'<>A ).

show_simple_ac( A ) :-
    output( A ).


/*
:- endmodule.
*/