diff options
Diffstat (limited to 'lib/gs/src/gstk_canvas.erl')
| -rw-r--r-- | lib/gs/src/gstk_canvas.erl | 516 |
1 files changed, 0 insertions, 516 deletions
diff --git a/lib/gs/src/gstk_canvas.erl b/lib/gs/src/gstk_canvas.erl deleted file mode 100644 index 102b81df7a..0000000000 --- a/lib/gs/src/gstk_canvas.erl +++ /dev/null @@ -1,516 +0,0 @@ -%% -%% %CopyrightBegin% -%% -%% Copyright Ericsson AB 1996-2016. All Rights Reserved. -%% -%% Licensed under the Apache License, Version 2.0 (the "License"); -%% you may not use this file except in compliance with the License. -%% You may obtain a copy of the License at -%% -%% http://www.apache.org/licenses/LICENSE-2.0 -%% -%% Unless required by applicable law or agreed to in writing, software -%% distributed under the License is distributed on an "AS IS" BASIS, -%% WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. -%% See the License for the specific language governing permissions and -%% limitations under the License. -%% -%% %CopyrightEnd% -%% - -%% -%% ------------------------------------------------------------ -%% Basic Canvas Type -%% ------------------------------------------------------------ - --module(gstk_canvas). --compile([{nowarn_deprecated_function,{gs,pair,2}}, - {nowarn_deprecated_function,{gs,val,2}}]). - -%%----------------------------------------------------------------------------- -%% CANVAS OPTIONS -%% -%% Attributes: -%% activebg Color -%% anchor n,w,s,e,nw,se,ne,sw,center -%% bc Color -%% bg Color -%% bw Wth -%% data Data -%% height Int -%% highlightbg Color -%% highlightbw Wth -%% highlightfg Color -%% hscroll Bool | top | bottom -%% relief Relief -%% scrollbg Color -%% scrollfg Color -%% scrollregion {X1, Y1, X2, Y2} -%% selectbg Color -%% selectbw Width -%% selectfg Color -%% vscroll Bool | left | right -%% width Int -%% x Int -%% y Int -%% -%% -%% Commands: -%% find {X, Y} => Item at pos X,Y or false -%% setfocus Bool -%% -%% Events: -%% buttonpress [Bool | {Bool, Data}] -%% buttonrelease [Bool | {Bool, Data}] -%% configure [Bool | {Bool, Data}] -%% destroy [Bool | {Bool, Data}] -%% enter [Bool | {Bool, Data}] -%% focus [Bool | {Bool, Data}] -%% keypress [Bool | {Bool, Data}] -%% keyrelease [Bool | {Bool, Data}] -%% leave [Bool | {Bool, Data}] -%% motion [Bool | {Bool, Data}] -%% -%% Read Options: -%% children -%% id -%% parent -%% type -%% -%% Not Implemented: -%% fg Color -%% - --export([create/3,config/3,read/3,delete/2,event/5,option/5,read_option/5]). --export([make_command/5,make_command/6,pickout_coords/4, coords/1, - item_config/3,mk_create_opts_for_child/4, - upd_gstkid/3,item_delete_impl/2,mk_cmd_and_exec/6,mk_cmd_and_call/5]). - --include("gstk.hrl"). - -%%----------------------------------------------------------------------------- -%% MANDATORY INTERFACE FUNCTIONS -%%----------------------------------------------------------------------------- -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%% Function : create/3 -%% Return : [Gsid_of_new_widget | {bad_result, Reason}] -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -create(DB, Gstkid, Opts) -> - MainW = gstk_generic:mk_tkw_child(DB,Gstkid), - Canvas = lists:append(MainW,".z"), - {Vscroll, Hscroll, NewOpts} = gstk_generic:parse_scrolls(Opts), - WidgetD = #so{main=MainW, object=Canvas, - hscroll=Hscroll, vscroll=Vscroll}, - NGstkid=Gstkid#gstkid{widget=MainW, widget_data=WidgetD}, - MandatoryCmd = ["so_create canvas ", MainW], - case gstk:call(MandatoryCmd) of - {result, _} -> - SimplePreCmd = [MainW, " conf"], - PlacePreCmd = [";place ", MainW], - gstk_db:insert_opt(DB,Gstkid,gs:pair(scrollregion,Opts)), - case gstk_generic:make_command(NewOpts, NGstkid, MainW, - SimplePreCmd, PlacePreCmd, DB,Canvas) of - {error,Reason} -> {error,Reason}; - Cmd when is_list(Cmd) -> - gstk:exec(Cmd), - gstk:exec([MainW,".sy conf -rel sunken -bo 2;", - MainW,".pad.sx conf -rel sunken -bo 2;"]), - NGstkid - end; - Bad_Result -> - {bad_result, Bad_Result} - end. - -mk_create_opts_for_child(DB,Cgstkid, Pgstkid, Opts) -> - gstk_generic:mk_create_opts_for_child(DB,Cgstkid,Pgstkid,Opts). - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%% Function : config/3 -%% Purpose : Configure a widget of the type defined in this module. -%% Args : DB - The Database -%% Gstkid - The gstkid of the widget -%% Opts - A list of options for configuring the widget -%% -%% Return : [true | {bad_result, Reason}] -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -config(DB, Gstkid, Options) -> - SO = Gstkid#gstkid.widget_data, - MainW = Gstkid#gstkid.widget, - Canvas = SO#so.object, - NewOpts = gstk_generic:parse_scrolls(Gstkid, Options), - SimplePreCmd = [MainW, " conf"], - PlacePreCmd = [";place ", MainW], - gstk_generic:mk_cmd_and_exec(NewOpts, Gstkid, MainW, - SimplePreCmd, PlacePreCmd, DB,Canvas). - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%% Function : read/3 -%% Purpose : Read one option from a widget -%% Args : DB - The Database -%% Gstkid - The gstkid of the widget -%% Opt - An option to read -%% -%% Return : [OptionValue | {bad_result, Reason}] -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -read(DB, Gstkid, Opt) -> - SO = Gstkid#gstkid.widget_data, - gstk_generic:read_option(DB, Gstkid, Opt,SO#so.object). - - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%% Function : delete/2 -%% Purpose : Delete widget from databas and return tkwidget to destroy -%% Args : DB - The Database -%% Gstkid - The gstkid of the widget -%% -%% Return : TkWidget to destroy -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -delete(DB, Gstkid) -> - gstk_db:delete_widget(DB, Gstkid), - Gstkid#gstkid.widget. - -event(DB, Gstkid, Etype, Edata, Args) -> - gstk_generic:event(DB, Gstkid, Etype, Edata, Args). - - -%%----------------------------------------------------------------------------- -%% MANDATORY FUNCTIONS -%%----------------------------------------------------------------------------- -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%% Function : option/5 -%% Purpose : Take care of options -%% Args : Option - An option tuple -%% Gstkid - The gstkid of the widget -%% MainW - The main tk-widget -%% Canvas - The canvas tk-widget -%% DB - The Database -%% -%% Return : A tuple {OptionType, OptionCmd} -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -option(Option,Gstkid,_MainW,DB,Canvas) -> - case Option of - {scrollregion, {X1, Y1, X2, Y2}} -> - gstk_db:insert_opt(DB,Gstkid,Option), - {c, [Canvas, " conf -scrollr {", - gstk:to_ascii(X1), " ", gstk:to_ascii(Y1), " ", - gstk:to_ascii(X2), " ", gstk:to_ascii(Y2),"}"]}; - {yscrollpos, Y} -> - {_,Ymin,_,Ymax} = gstk_db:opt(DB,Gstkid,scrollregion), - K = 1/(Ymax-Ymin), - M = -K*Ymin, - PercentOffViewTop = K*Y+M, - {c, [Canvas," yvi mo ",gstk:to_ascii(PercentOffViewTop)]}; - {xscrollpos, X} -> - {Xmin,_,Xmax,_} = gstk_db:opt(DB,Gstkid,scrollregion), - K = 1/(Xmax-Xmin), - M = -K*Xmin, - PercentOffViewLeft = K*X+M, - {c, [Canvas," xvi mo ",gstk:to_ascii(PercentOffViewLeft)]}; - {buttonpress, On} -> bind(DB, Gstkid, Canvas, buttonpress, On); - {buttonrelease, On} -> bind(DB, Gstkid, Canvas, buttonrelease, On); - {configure, On} -> bind(DB, Gstkid, Canvas, configure, On); - {destroy, On} -> bind(DB, Gstkid, Canvas, destroy, On); - {enter, On} -> bind(DB, Gstkid, Canvas, enter, On); - {focus, On} -> bind(DB, Gstkid, Canvas, focus, On); - {keypress, On} -> bind(DB, Gstkid, Canvas, keypress, On); - {keyrelease, On} -> bind(DB, Gstkid, Canvas, keyrelease, On); - {leave, On} -> bind(DB, Gstkid, Canvas, leave, On); - {motion, On} -> bind(DB, Gstkid, Canvas, motion, On); - - {secret_hack_gridit, GridGstkid} -> - CRef = gstk_db:insert_event(DB, GridGstkid, click, []), - ClickCmd = [Canvas, " bind all <ButtonRelease-1> {erlsend ", CRef, - " [",Canvas, " find withtag current]};"], - DRef = gstk_db:insert_event(DB, GridGstkid, doubleclick, []), - DclickCmd = [Canvas," bind all <Double-ButtonRelease-1> {erlsend ", - DRef," [",Canvas, " find withtag current]}"], - %% bind all at once for preformance reasons. - {c, [ClickCmd,DclickCmd]}; - {secret_forwarded_grid_event, {Event,On},GridGstkid} -> - bind(DB,GridGstkid,Canvas,Event,On); - _ -> invalid_option - end. - - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%% Function : read_option/5 -%% Purpose : Take care of a read option -%% Return : The value of the option or invalid_option -%% [OptionValue | {bad_result, Reason}] -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -read_option(Option,Gstkid,_MainW,DB,Canvas) -> - case Option of - scrollregion -> gstk_db:opt(DB,Gstkid,scrollregion); - {hit, {X,Y}} -> - hit(DB,Canvas,X,Y,X,Y); - {hit, [{X1,Y1},{X2,Y2}]} -> - hit(DB,Canvas,X1,Y1,X2,Y2); - % {% hidden above, % of total area that is visible + % hidden above} - yscrollpos -> - {PercentOffViewTop,_} = tcl2erl:ret_tuple([Canvas," yvi"]), - {_,Ymin,_,Ymax} = gstk_db:opt(DB,Gstkid,scrollregion), - K = 1/(Ymax-Ymin), - M = -K*Ymin, - _Y = round((PercentOffViewTop - M)/K); - xscrollpos -> - {PercentOffViewLeft,_} = tcl2erl:ret_tuple([Canvas," xvi"]), - {Xmin,_,Xmax,_} = gstk_db:opt(DB,Gstkid,scrollregion), - K = 1/(Xmax-Xmin), - M = -K*Xmin, - _X = round((PercentOffViewLeft-M)/K); - buttonpress -> gstk_db:is_inserted(DB, Gstkid, buttonpress); - buttonrelease -> gstk_db:is_inserted(DB, Gstkid, buttonrelease); - configure -> gstk_db:is_inserted(DB, Gstkid, configure); - destroy -> gstk_db:is_inserted(DB, Gstkid, destroy); - enter -> gstk_db:is_inserted(DB, Gstkid, enter); - focus -> gstk_db:is_inserted(DB, Gstkid, focus); - keypress -> gstk_db:is_inserted(DB, Gstkid, keypress); - keyrelease -> gstk_db:is_inserted(DB, Gstkid, keyrelease); - leave -> gstk_db:is_inserted(DB, Gstkid, leave); - motion -> gstk_db:is_inserted(DB, Gstkid, motion); - - _ -> {bad_result, {Gstkid#gstkid.objtype, invalid_option, Option}} - end. - -hit(DB,Canvas,X1,Y1,X2,Y2) -> - Ax1 = gstk:to_ascii(X1), - Ay1 = gstk:to_ascii(Y1), - Ax2 = gstk:to_ascii(X2), - Ay2 = gstk:to_ascii(Y2), - case tcl2erl:ret_list([Canvas," find overlapping ", - Ax1,$ ,Ay1,$ ,Ax2,$ ,Ay2]) of - Items when is_list(Items) -> - [{_,Node}] = ets:lookup(DB,frontend_node), - fix_ids(Items,DB,Canvas,Node); - Other -> - {bad_result, Other} - end. - -fix_ids([Item|Items],DB,Canvas,Node) -> - [{gstk_db:lookup_item(DB,Canvas,Item),Node}|fix_ids(Items,DB,Canvas,Node)]; -fix_ids([],_,_,_) -> []. - -%%----------------------------------------------------------------------------- -%% PRIMITIVES -%%----------------------------------------------------------------------------- - -%% -%% Event bind main function -%% -%% Should return a list of tcl commands or invalid_option -%% -%% WS = Widget suffix for c widgets -%% -bind(DB, Gstkid, TkW, Etype, On) -> - case bind(DB, Gstkid, TkW, Etype, On, "") of - invalid_option -> invalid_option; - Cmd -> {c, Cmd} - end. - -bind(DB, Gstkid, TkW, Etype, On, WS) -> - case On of - true -> ebind(DB, Gstkid, TkW, Etype, WS, ""); - false -> eunbind(DB, Gstkid, TkW, Etype, WS, ""); - {true, Edata} -> ebind(DB, Gstkid, TkW, Etype, WS, Edata); - {false, Edata} -> eunbind(DB, Gstkid, TkW, Etype, WS, Edata); - _ -> invalid_option - end. - - -%% -%% Event bind on -%% -%% Should return a list of tcl commands or invalid_option -%% -%% WS = Widget suffix for complex widgets -%% -ebind(DB, Gstkid, TkW, Etype, WS, Edata) -> - Eref = gstk_db:insert_event(DB, Gstkid, Etype, Edata), - P = ["bind ", TkW, WS], - Cmd = case Etype of - motion -> [P, " <Motion> {erlsend ", Eref, " [", - TkW, " canvasx %x] [", TkW, " canvasy %y] %x %y}"]; - keypress -> - [P, " <Key> {erlsend ", Eref," %K %N 0 0 [", - TkW, " canvasx %x] [", TkW, " canvasy %y]};", - P, " <Shift-Key> {erlsend ", Eref, " %K %N 1 0 [", - TkW, " canvasx %x] [", TkW, " canvasy %y]};", - P, " <Control-Key> {erlsend ", Eref, " %K %N 0 1 [", - TkW, " canvasx %x] [", TkW, " canvasy %y]};", - P, " <Control-Shift-Key> {erlsend ", Eref," %K %N 1 1 [", - TkW, " canvasx %x] [", TkW, " canvasy %y]}"]; - keyrelease -> - [P, " <KeyRelease> {erlsend ", Eref," %K %N 0 0 [", - TkW, " canvasx %x] [", TkW, " canvasy %y]};", - P, " <Shift-KeyRelease> {erlsend ", Eref, " %K %N 1 0 [", - TkW, " canvasx %x] [", TkW, " canvasy %y]};", - P, " <Control-KeyRelease> {erlsend ", Eref, " %K %N 0 1 [", - TkW, " canvasx %x] [", TkW, " canvasy %y]};", - P," <Control-Shift-KeyRelease> {erlsend ",Eref," %K %N 1 1[", - TkW, " canvasx %x] [", TkW, " canvasy %y]}"]; - buttonpress -> - [P, " <Button> {erlsend ", Eref, " %b [", - TkW, " canvasx %x] [", TkW, " canvasy %y] %x %y}"]; - buttonrelease -> - [P, " <ButtonRelease> {erlsend ", Eref, " %b [", - TkW, " canvasx %x] [", TkW, " canvasy %y] %x %y}"]; - leave -> [P, " <Leave> {erlsend ", Eref, "}"]; - enter -> [P, " <Enter> {erlsend ", Eref, "}"]; - destroy -> - [P, " <Destroy> {if {\"%W\"==\"", [TkW, WS], - "\"} {erlsend ", Eref, "}}"]; - focus -> - [P, " <FocusIn> {erlsend ", Eref, " true};" , - P, " <FocusOut> {erlsend ", Eref, " false}"]; - configure -> - [P, " <Configure> {if {\"%W\"==\"", [TkW, WS], - "\"} {erlsend ", Eref, " %w %h %x %y}}"] - end, - Cmd. - - -%% -%% Unbind event -%% -%% Should return a list of tcl commands -%% Already checked for validation in bind/5 -%% -%% WS = Widget suffix for complex widgets -%% -eunbind(DB, Gstkid, TkW, Etype, WS, _Edata) -> - gstk_db:delete_event(DB, Gstkid, Etype), - P = ["bind ", TkW, WS], - Cmd = case Etype of - motion -> - [P, " <Motion> {}"]; - keypress -> - [P, " <KeyRelease> {};", - P, " <Shift-KeyRelease> {};", - P, " <Control-KeyRelease> {};", - P, " <Control-Shift-KeyRelease> {}"]; - keyrelease -> - [P, " <KeyRelease> {};", - P, " <Shift-KeyRelease> {};", - P, " <Control-KeyRelease> {};", - P, " <Control-Shift-KeyRelease> {}"]; - buttonpress -> - [P, " <ButtonPress> {}"]; - buttonrelease -> - [P, " <ButtonRelease> {}"]; - leave -> - [P, " <Leave> {}"]; - enter -> - [P, " <Enter> {}"]; - destroy -> - [P, " <Destroy> {}"]; - focus -> - [P, " <FocusIn> {};", - P, " <FocusOut> {}"]; - configure -> - [P, " <Configure> {}"] - end, - Cmd. - -%%====================================================================== -%% Item library -%%====================================================================== - -mk_cmd_and_exec(Options, Gstkid, Canvas, AItem, SCmd, DB) -> - case make_command(Options, Gstkid, Canvas, AItem, SCmd, DB) of - {error,Reason} -> {error,Reason}; - Cmd when is_list(Cmd) -> - gstk:exec(Cmd) - end. - -mk_cmd_and_call(Opts,Gstkid, CanvasTkW, MCmd, DB) -> - case make_command(Opts,Gstkid, CanvasTkW, MCmd, DB) of - {error,Reason} -> {error,Reason}; - Cmd when is_list(Cmd) -> - case tcl2erl:ret_int(Cmd) of - Item when is_integer(Item) -> - G2 = gstk_db:lookup_gstkid(DB,Gstkid#gstkid.id), % buu, not nice - NewGstkid = G2#gstkid{widget_data=Item}, - NewGstkid; - Bad_result -> - {error,Bad_result} - end - end. - - -%%---------------------------------------------------------------------- -%% MCmd = Mandatory command -%% Comment: The problem: Create everything in one async command and -%% get the canvas obj integer id no back then. -%% The trick is to do: -%% set w [canvas create rectangle x1 y1 x2 y2 -Option Value ...]; -%% canvas Action $w ;$w -%% Comment: no placer options (we don't have to consider all permutations) -%%---------------------------------------------------------------------- -make_command(Options, Gstkid, Canvas, AItem, SCmd, DB) -> - case gstk_generic:out_opts(Options,Gstkid,Canvas,DB,AItem, [],[],[]) of - {[], [], []} -> []; - {Si, [], []} -> [SCmd, Si]; - {[], [], Co} -> Co; - {Si, [], Co} -> [SCmd, Si, $;, Co]; - {error,Reason} -> {error,Reason} - end. - -make_command(Options, Gstkid, Canvas, MCmd, DB) -> - case gstk_generic:out_opts(Options,Gstkid,Canvas,DB,"$w",[],[],[]) of - {[], [], []} -> MCmd; - {Si, [], []} -> [MCmd, Si]; - {[], [], Co} -> ["set w [", MCmd, "];", Co, "set d $w"]; - {Si, [], Co} -> ["set w [", MCmd, Si, "];", Co, "set d $w"]; - {error,Reason} -> {error,Reason} - end. - -item_config(DB, Gstkid, Opts) -> - #gstkid{widget=Canvas,widget_data=Item}=Gstkid, - AItem = gstk:to_ascii(Item), - SCmd = [Canvas, " itemconf ", AItem], - case make_command(Opts, Gstkid, Canvas, AItem, SCmd, DB) of - {error,Reason} -> {error,Reason}; - Cmd when is_list(Cmd) -> - gstk:exec(Cmd) - end. - -pickout_coords([{coords,Coords} | Rest], Opts, ObjType, NbrOfCoords) - when length(Coords) == NbrOfCoords -> - case coords(Coords) of - invalid -> - {error, io_lib:format("A ~w must have ~w coordinates", - [ObjType,NbrOfCoords])}; - RealCoords -> - {RealCoords, lists:append(Rest, Opts)} - end; -pickout_coords([Opt | Rest], Opts, ObjType, NbrOfCoords) -> - pickout_coords(Rest, [Opt|Opts], ObjType, NbrOfCoords); -pickout_coords([], _Opts, ObjType, NbrOfCoords) -> - {error, io_lib:format("A ~w must have ~w coordinates", - [ObjType,NbrOfCoords])}. - -coords([{X,Y} | R]) when is_number(X),is_number(Y) -> - [gstk:to_ascii(X), " ", gstk:to_ascii(Y), " ", coords(R)]; -coords([_]) -> %% not a pair - invalid; -coords([]) -> - []. - -item_delete_impl(DB,Gstkid) -> - gstk_db:delete_widget(DB, Gstkid), - #gstkid{widget=Canvas,widget_data=Item,parent=P,id=ID,objtype=Type}=Gstkid, - {P,ID,gstk_widgets:type2mod(Type), [Canvas, Item]}. - - -upd_gstkid(DB, Gstkid, Opts) -> - #gstkid{parent=Parent,owner=Owner}=Gstkid, - Pgstkid = gstk_db:lookup_gstkid(DB, Parent, Owner), - SO = Pgstkid#gstkid.widget_data, - CanvasTkW = SO#so.object, - gstk_db:insert_opt(DB,Gstkid,{coords,gs:val(coords,Opts)}), - gstk_db:update_widget(DB,Gstkid#gstkid{widget=CanvasTkW,widget_data=no_item}). - - -%%% ----- Done ----- - - |