/* Part of XPCE --- The SWI-Prolog GUI toolkit
Author: Jan Wielemaker and Anjo Anjewierden
E-mail: jan@swi.psy.uva.nl
WWW: http://www.swi.psy.uva.nl/projects/xpce/
Copyright (c) 1985-2002, University of Amsterdam
All rights reserved.
Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions
are met:
1. Redistributions of source code must retain the above copyright
notice, this list of conditions and the following disclaimer.
2. Redistributions in binary form must reproduce the above copyright
notice, this list of conditions and the following disclaimer in
the documentation and/or other materials provided with the
distribution.
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,
INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
POSSIBILITY OF SUCH DAMAGE.
*/
:- module(dia_generate, [source/2, new_term/2]).
:- use_module(library(pce)).
:- use_module(proto).
:- require([ append/3
, between/3
, chain_list/2
, delete/3
, forall/2
, genarg/3
, get_chain/3
, list_to_set/2
, maplist/3
, member/2
, memberchk/2
, portray_object/2
, subtract/3
, term_to_atom/2
]).
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
Format description:
dialog(<key>(<Arg> ...),
[ <attribute> := <value>,
...
]).
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
:- dynamic
reference/2.
source(Dialog, Source) :-
retractall(reference(_,_)),
findall(P, parameter(Dialog, P), Ps),
menu_items(Dialog),
findall(Attr := Value, source_attribute(Dialog, Attr, Value), List),
reference(ObjectRef, Dialog),
get(Dialog, name, Id),
IdTerm =.. [Id|Ps],
Source =.. [dialog, IdTerm, [object := ObjectRef | List]].
% retractall(reference(_,_)). % TBD
:- discontiguous
source_attribute/3.
/*******************************
* PARAMETERS *
*******************************/
parameter(Dialog, P) :-
get(Dialog, behaviour_model, Model),
get_chain(Model, graphicals, Grs),
findall('$aref'(RefName), (member(Gr, Grs),
send(Gr, instance_of, msg_parameter_port),
get(Gr, parameter_name, PName),
prolog_variable_name(PName, RefName),
asserta(reference('$aref'(RefName), Gr))),
Parms),
member(P, Parms).
/*******************************
* MENU_ITEMS *
*******************************/
menu_items(Dialog) :-
get(Dialog, behaviour_model, Model),
get_chain(Model, graphicals, Grs),
member(Gr, Grs),
send(Gr, instance_of, msg_object),
get(Gr, ui_object, UI),
send(UI, instance_of, menu_item),
get(UI, value, ValueName),
prolog_variable_name(ValueName, RefName),
asserta(reference('$aref'(RefName), UI)),
fail.
menu_items(_).
/*******************************
* PARTS *
*******************************/
source_attribute(Dialog, parts, TheItems) :-
get_chain(Dialog, graphicals, Grs),
findall('$aref'(RefName) := NewTerm,
(member(Gr, [Dialog|Grs]),
\+ get(Dialog, overlay, Gr),
new_term(Gr, NewTerm),
get(Gr, name, GrName),
prolog_variable_name(GrName, RefName),
asserta(reference('$aref'(RefName), Gr))),
Items),
generate_unique_variable_names(Items, [], TheItems).
generate_unique_variable_names([], _, []).
generate_unique_variable_names([Part|Parts], Done, [NewPart|NewParts]) :-
varname(Part, Ref),
( occurs(Done, Ref, DoneTimes),
DoneTimes > 0
-> Id is DoneTimes + 1,
atom_concat(Ref, Id, NewRef),
set_varname(Part, NewRef, NewPart),
generate_unique_variable_names(Parts, [Part|Done], NewParts)
; occurs(Parts, Ref, Times),
( Times == 0
-> NewPart = Part,
generate_unique_variable_names(Parts, [Part|Done], NewParts)
; occurs(Done, Ref, DoneTimes),
Id is DoneTimes + 1,
atom_concat(Ref, Id, NewRef),
set_varname(Part, NewRef, NewPart),
generate_unique_variable_names(Parts, [Part|Done], NewParts)
)
).
varname('$aref'(Name) := _, Name).
set_varname('$aref'(Old) := Value, Var, '$aref'(Var) := Value) :-
retract(reference('$aref'(Old), Gr)),
!,
assert(reference('$aref'(Var), Gr)).
occurs([], _, 0).
occurs([H|T], Var, Times) :-
varname(H, Var),
!,
occurs(T, Var, T0),
Times is T0 + 1.
occurs([_H|T], Var, Times) :-
occurs(T, Var, Times).
/*******************************
* MODIFICATIONS *
*******************************/
source_attribute(Dialog, modifications, Modifications) :-
get_chain(Dialog, graphicals, Grs),
findall(Ref := Atts,
(member(Gr, Grs),
\+ get(Dialog, overlay, Gr),
object_attributes(Gr, Atts),
Atts \== [],
reference(Ref, Gr)),
Modifications).
/*******************************
* LAYOUT INFO *
*******************************/
source_attribute(Dialog, layout, Layout) :-
get_chain(Dialog, graphicals, Grs),
get(Dialog, overlay, Overlay),
delete(Grs, Overlay, Items),
findall(Alignment, alignment(Items, Alignment), P0),
maplist(canonicalise_alignment, P0, P1),
list_to_set(P1, P2),
maplist(symbolic_pair, P2, Pairs),
aligned(P2, Aligned),
subtract(Items, Aligned, Explicit),
findall(area(Ref, Area),
(member(I, Explicit),
reference(Ref, I),
get_argument(I, area, Area)),
Positions),
append(Pairs, Positions, Layout).
alignment(Items, Alignment) :-
pair(I1, I2, Items),
alignment(I1, I2, Alignment).
alignment(I1, I2, below(I1, I2)) :- get(I2, below, I1).
alignment(I1, I2, above(I1, I2)) :- get(I2, above, I1).
alignment(I1, I2, left(I1, I2)) :- get(I2, left, I1).
alignment(I1, I2, right(I1, I2)) :- get(I2, right, I1).
pair(I1, I2, [I1|L]) :-
member(I2, L).
pair(I1, I2, [_|T]) :-
pair(I1, I2, T).
canonicalise_alignment(left(I1, I2), right(I2, I1)) :- !.
canonicalise_alignment(above(I1, I2), below(I2, I1)) :- !.
canonicalise_alignment(A, A).
aligned(Pairs, Items) :-
aligned_(Pairs, I0),
sort(I0, Items). % unqiue
aligned_([], []).
aligned_([H|T], [I1,I2|R]) :-
H =.. [_, I1, I2],
aligned_(T, R).
symbolic_pair(Term, Refs) :-
Term =.. L,
maplist(to_reference, R, L),
Refs =.. R.
to_reference(Symbol, Ref) :-
reference(Symbol, Ref),
!.
to_reference(X, X).
/*******************************
* POPUPS *
*******************************/
source_attribute(Dialog, popups, Popups) :-
get_chain(Dialog, graphicals, Grs),
findall(Ref := Popup,
(member(Gr, Grs),
\+ get(Dialog, overlay, Gr),
popup(Gr, Popup),
reference(Ref, Gr)),
Popups),
Popups \== [].
popup(Gr, [ popup := NewTerm, Attributes ]) :-
( send(Gr, instance_of, menu),
get(Gr, kind, cycle)
-> fail
; get(Gr, popup, Popup),
Popup \== @nil,
new_term(Popup, NewTerm),
object_attributes(Popup, Attributes)
).
/*******************************
* BEHAVIOUR *
*******************************/
behaviour_object(O, R) :-
send(O, instance_of, menu_item),
!,
reference(R, O).
behaviour_object(O, O) :-
O = @Ref,
atom(Ref),
\+ send(O, instance_of, graphical).
source_attribute(Dialog, behaviour, Behaviour) :-
get_chain(Dialog, graphicals, Grs),
findall(Ref := Dyns,
(member(Gr, Grs),
\+ get(Dialog, overlay, Gr),
get(Gr, behaviour_model, Bgr),
behaviour(Bgr, Dyns),
Dyns \== [],
reference(Ref, Gr)),
B0),
get(Dialog, behaviour_model, Model),
get_chain(Model, graphicals, BMs),
findall(R := Dyns,
(member(BM, BMs),
send(BM, instance_of, msg_object),
get(BM, ui_object, O),
behaviour_object(O, R),
behaviour(BM, Dyns),
Dyns \== []),
B1),
append(B0, B1, Behaviour),
Behaviour \== [].
source_attribute(Dialog, initialise, Initialise) :-
get(Dialog, behaviour_model, Model),
get(Model?graphicals, find_all,
message(@arg1, instance_of, msg_init_port), Chain),
chain_list(Chain, Ports),
Ports \== [],
findall(Send,
(member(Port, Ports),
port_message(Port, Message),
( message_to_call(Message, Send)
-> true
; get(Port, name, Name),
Send = (Name := Message)
)),
Initialise).
message_to_call(Message, Send) :-
functor(Message, message, _),
!,
Message =.. [_|Args],
Send =.. [send|Args].
behaviour(Object, Dyns) :-
get(Object?graphicals, find_all,
message(@arg1, instance_of, msg_event_port),
Chain),
chain_list(Chain, EventPorts),
findall(Name := Message,
(member(Port, EventPorts),
get(Port, name, Name),
port_message(Port, Message)),
Dyns).
port_message(Port, Message) :-
get(Port, connections, Cs),
get(Cs, find_all, @arg1?type == activate, Activations),
chain_list(Activations, List),
maplist(activation_message, List, Messages),
( Messages = [Message]
-> true
; Message =.. [and|Messages] % order?
).
activation_message(C, Message) :-
get(C, to, CallPort),
get(CallPort, name, Selector),
get(CallPort, object, Object),
receiver(Object, Receiver),
activation_arguments(C, Args),
TheMessage =.. [message, Receiver, Selector | Args],
activation_conditions(C, Conditions),
( Conditions == []
-> Message = TheMessage
; RawCond =.. [and | Conditions],
simplify(RawCond, Cond),
Message = if(Cond, TheMessage)
).
activation_conditions(C, Conditions) :-
( get(C, connections, Cs)
-> get(Cs, find_all, @arg1?type == condition, Cds),
chain_list(Cds, List),
maplist(condition, List, Conditions)
; Conditions = []
).
condition(C, Cond) :-
activation_message(C, Cond).
receiver(Object, Receiver) :-
get(Object, connections, Cs),
get(Cs, find, @arg1?type == expansion, E),
!,
get(E, from, Port),
get(Port, object, O2),
get(Port, name, Selector),
receiver(O2, R2),
activation_arguments(E, Args),
Obtainer =.. [?, R2, Selector | Args],
simplify(Obtainer, Receiver).
receiver(Object, Receiver) :-
get(Object, ui_object, Self),
!,
( reference(Receiver, Self)
-> true
; Self = @Atom,
atom(Atom)
-> Receiver = Self
; pce_to_prolog(Self, Receiver)
).
activation_arguments(C, Args) :-
( get(C, connections, Cs)
-> get(Cs, find_all, @arg1?type == argument, A0),
chain_list(A0, L0),
maplist(activation_argument, L0, ParmArgs),
sort(ParmArgs, Sorted),
argument_list(Sorted, PositionArgs, NamedArgs),
append(PositionArgs, NamedArgs, Args)
; Args = []
).
argument_list([], [], []).
argument_list([N := A|T], PosArgs, [N := A|R]) :-
atom(N),
!,
argument_list(T, PosArgs, R).
argument_list([_ := A|T], [A|R], NamedArgs) :-
argument_list(T, R, NamedArgs).
activation_argument(A, Parm := Arg) :-
get(A, from, Port),
get(A, parameter, Parm),
( send(Port, instance_of, msg_constant_port)
-> get(Port, name, TermAtom),
term_to_atom(Arg, TermAtom)
; send(Port, instance_of, msg_parameter_port)
-> reference(Arg, Port)
; send(Port, instance_of, msg_get_port)
-> get(Port, object, Object),
get(Port, name, Selector),
receiver(Object, Receiver),
activation_arguments(A, Args),
Obtainer =.. [?, Receiver, Selector | Args],
simplify(Obtainer, Arg)
).
simplify(X?self, S) :-
!,
simplify(X, S).
simplify(and(X), S) :-
!,
simplify(X, S).
simplify(X, S) :-
simplify_forward(X, S),
!.
simplify(X, X).
% map message(X, forward, a, b, c). Is this ok? What if not
% all arguments are handled?
simplify_forward(Message, Simple) :-
Message =.. [message, _R, forward | Args],
make_mapping(Args, Mapping),
map_term(Mapping, Message, Mapped),
Mapped =.. [message, Code, forward | Args],
\+ argleft(Mapped),
!,
Simple = Code.
simplify_forward(Obtainer, Simple) :-
Obtainer =.. [?, _F, '_forward' | Args],
make_mapping(Args, Mapping),
map_term(Mapping, Obtainer, Mapped),
Mapped =.. [?, Code, '_forward' | Args],
\+ argleft(Mapped),
!,
( Code = quote_function(Simple)
; Simple = Code
).
argleft(@Ref) :-
atom_concat(arg, N, Ref),
get(@pce, convert, N, int, _),
!.
argleft(Atomic) :-
atomic(Atomic),
!,
fail.
argleft(Term) :-
genarg(_, Term, Arg),
argleft(Arg),
!.
make_mapping(Args, Mapping) :-
make_mapping(Args, 1, Mapping).
make_mapping([], _, []).
make_mapping([H|T], N, [@ArgN = H|R]) :-
atom_concat(arg, N, ArgN),
NN is N + 1,
make_mapping(T, NN, R).
% map_term(+[From = To, ...], +Term, -MappedTerm).
map_term(Mapping, Term, NewTerm) :-
memberchk(Term = NewTerm, Mapping),
!.
map_term(Mapping, Term, NewTerm) :-
functor(Term, Name, Arity),
functor(NewTerm, Name, Arity),
map_argument(1, Arity, Mapping, Term, NewTerm).
map_argument(N, M, Mapping, Term, NewTerm) :-
arg(N, Term, A1),
!,
arg(N, NewTerm, A2),
map_term(Mapping, A1, A2),
NN is N + 1,
map_argument(NN, M, Mapping, Term, NewTerm).
map_argument(_, _, _, _, _).
/*******************************
* NEW-TERM *
*******************************/
new_term(Object, Term) :-
proto(Object, Proto),
proto_term(Proto, Functor, ProtoArgs),
!,
new_proto_term(Proto, Functor, Args),
maplist(new_argument(Object), Args, Values),
( length(Args, L),
length(ProtoArgs, L)
-> true % no more arguments
; maplist(try_argument, Values, TryValues),
new_term(Functor, TryValues, TryTerm),
new(Tmp, TryTerm),
( equal_on_remaining_proto_args(Values, ProtoArgs, Object, Tmp)
-> !,
free(Tmp)
; free(Tmp),
fail
)
),
new_term(Functor, Values, RawTerm),
( Functor == menu_item,
reference(Ref, Object)
-> Term = new(Ref, RawTerm)
; Term = RawTerm
).
new_term(Object, Term) :-
portray_object(Object, Term).
% new_term(+Class, +Args, -Term)
% Create a term that can be handed as an argument to create an
% instance of the class.
new_term(Class, Args, Term) :-
append(NonDef, Def, Args),
maplist(=(@default), Def),
!,
( NonDef == []
-> Term = new(Class)
; Term =.. [Class|NonDef]
).
code_class(message).
code_class(and).
% try_argument(+Arg, -Try)
% Code arguments normally contain $aref(_) terms and thus cannot
% be handed to the temporary term. Just hand in a dummy argument
% to fix to avoid the error.
:- pce_global(@dia_dummy_code, new(or)).
try_argument(A, @dia_dummy_code) :-
functor(A, Class, _),
code_class(Class),
!.
try_argument(A, A).
new_argument(_, _Name := Value, Value) :- !.
new_argument(O, Name, Value) :-
get_argument(O, Name, Value).
new_proto_term(Proto, Functor, Args) :-
proto_term(Proto, Functor, ProtoArgs),
delete_optional_new_arguments(ProtoArgs, Args).
delete_optional_new_arguments([], []).
delete_optional_new_arguments([[_]|_], []).
delete_optional_new_arguments([[X]|T], [X|R]) :-
!,
delete_optional_new_arguments(T, R).
delete_optional_new_arguments([H|T], [H|R]) :-
delete_optional_new_arguments(T, R).
equal_on_remaining_proto_args([], Args, O1, O2) :-
equal_on_remaining_proto_args(Args, O1, O2).
equal_on_remaining_proto_args([_|V], [_|T], O1, O2) :-
equal_on_remaining_proto_args(V, T, O1, O2).
equal_on_remaining_proto_args([], _, _).
equal_on_remaining_proto_args([[Sel]|T], O1, O2) :-
!,
get_argument(O1, Sel, V1),
get_argument(O2, Sel, V2),
V1 = V2,
equal_on_remaining_proto_args(T, O1, O2).
equal_on_remaining_proto_args([_|T], O1, O2) :-
equal_on_remaining_proto_args(T, O1, O2).
/*******************************
* OBJECT ATTRIBUTES *
*******************************/
object_attributes(Object, List) :-
new_term(Object, NewTerm),
new(Tmp, NewTerm),
send(Tmp, obtain_class_variables),
findall(Attr := Value,
object_attribute(Object, Tmp, Attr, Value),
List),
free(Tmp).
object_attribute(Object, Tmp, Attr, Value) :-
proto(Object, Proto),
proto_source_attribute(_Mode, Proto, Attribute),
( atom(Attribute)
-> Attr = Attribute
; functor(Attribute, Attr, _Arity)
),
get_argument(Object, Attr, Value),
send(Tmp, compute),
( get_argument(Tmp, Attr, DefValue),
DefValue == Value
-> fail % donot generate argument
; send(Tmp, Attr, Value)
).
object_attribute(Object, _Tmp, append, Value) :- % menu_items of a menu
send(Object, instance_of, menu),
get(Object, members, Chain),
chain_list(Chain, Items),
findall(MenuItemTerm,
(member(Item, Items),
new_term(Item, NewTerm),
simplify_item(NewTerm, MenuItemTerm)),
Value).
simplify_item(menu_item(Value), Value) :- !.
simplify_item(Item, Item).
delete_attribute(_, fixed_reference).
delete_attribute(_, fixed_alignment).
delete_attribute(_, has_popup).
delete_attribute(_, popup_items(_)).
delete_attribute(_, members).
delete_attribute(popup, reference).
attribute_mapping(reference_x, reference).
attribute_mapping(reference_y, reference).
map_attribute(A, M) :-
attribute_mapping(A, M),
!.
map_attribute(A, A).
proto_source_attribute(Mode, Proto, Attr) :-
findall(A, attribute(Mode, Proto, A), S0),
maplist(map_attribute, S0, S1),
list_to_set(S1, S2),
member(Attr, S2),
\+ delete_attribute(Proto, Attr).
/*******************************
* BEHAVIOUR-MODEL *
*******************************/
/*
source_attribute(Target, behaviour_model, ModelSource) :-
get(Target, hypered, behaviour_model, Model).
*/
/*******************************
* GET-ARGUMENT *
*******************************/
get_argument(Object, Name, PortMessage) :-
get(Object, Name, Message),
send(Message, instance_of, message),
send(Object, has_get_method, proto), % dubious test
get(Object, behaviour_model, Model),
get(Message, receiver, Object),
!,
get(Model, member, Name, Port),
( port_message(Port, PortMessage)
-> true
; PortMessage = @default
).
get_argument(Object, Name, Value) :-
get(Object, Name, PceValue),
pce_to_prolog(PceValue, Value).
pce_to_prolog(Atomic, Atomic) :-
atomic(Atomic),
!.
pce_to_prolog(@Atom, @Atom) :-
atom(Atom),
!.
pce_to_prolog(Ref, Term) :-
portray_object(Ref, Term). % TBD
/*******************************
* PROPOSE A VARIABLE-NAME *
*******************************/
translate_char(Char, Char) :-
between(0'a, 0'z, Char),
!.
translate_char(Char, Char) :-
between(0'A, 0'Z, Char),
!.
translate_char(_, 0'_).
prolog_variable_name(GrName, VarName) :-
new(Str, string(GrName)),
send(Str, strip),
get(Str, size, Size),
End is Size - 1,
forall(between(0, End, Index),
(get(Str, character, Index, C0),
translate_char(C0, C1),
send(Str, character, Index, C1))),
get(Str, label_name, Str2),
send(Str2, translate, ' ', '_'),
get(Str2, character, 0, First),
( between(0'a, 0'z, First)
-> Up is First + 0'A - 0'a,
send(Str2, character, 0, Up)
; true
),
get(Str2, value, VarName).
proto(Object, Proto) :-
send(Object, has_get_method, proto),
!,
get(Object, proto, Proto).
proto(Object, Proto) :-
get(Object, class_name, Proto).