The R13B03 release.OTP_R13B03

1 files changed, 298 insertions, 0 deletions

diff --git a/lib/gs/src/gstk_gridline.erl b/lib/gs/src/gstk_gridline.erl
new file mode 100644
index 0000000000..c1dd5a1443
--- /dev/null
+++ b/lib/gs/src/gstk_gridline.erl
@@ -0,0 +1,298 @@
+%%
+%% %CopyrightBegin%
+%% 
+%% Copyright Ericsson AB 1996-2009. All Rights Reserved.
+%% 
+%% The contents of this file are subject to the Erlang Public License,
+%% Version 1.1, (the "License"); you may not use this file except in
+%% compliance with the License. You should have received a copy of the
+%% Erlang Public License along with this software. If not, it can be
+%% retrieved online at http://www.erlang.org/.
+%% 
+%% Software distributed under the License is distributed on an "AS IS"
+%% basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See
+%% the License for the specific language governing rights and limitations
+%% under the License.
+%% 
+%% %CopyrightEnd%
+%%
+
+%%
+-module(gstk_gridline).
+
+-export([event/5,create/3,config/3,option/5,read/3,delete/2,destroy/3,
+	read_option/5]).
+
+-include("gstk.hrl").
+-record(state,{canvas,ncols,max_range,cell_id, cell_pos,ids,db,tkcanvas}).
+-record(item,{text_id,rect_id,line_id}).
+
+%%-----------------------------------------------------------------------------
+%% 			    GRIDLINE OPTIONS
+%%
+%%	text		Text
+%%	row             Row
+%%	data		Data
+%%	fg		Color (default is the same as grid fg)
+%%	click         	Bool
+%%
+%%-----------------------------------------------------------------------------
+
+create(DB, Gstkid, Options) ->
+    Pgstkid = gstk_db:lookup_gstkid(DB,Gstkid#gstkid.parent),
+    Id = Gstkid#gstkid.id,
+    #gstkid{widget_data=State} = Pgstkid,
+    #state{cell_pos=CP,tkcanvas=TkW,ncols=Ncols} = State,
+    Row = gs:val(row,Options),
+    case check_row(CP,Row) of
+	{error,Reason} -> {error,Reason};
+	ok ->
+	    Ngstkid = Gstkid#gstkid{widget=TkW},
+	    gstk_db:insert_opts(DB,Id,[{data,[]},{row,Row}]),
+	    update_cp_db(Ncols,Row,Id,CP),
+	    config_line(DB,Pgstkid,Ngstkid,Row,Options),
+	    Ngstkid
+    end.
+
+%%----------------------------------------------------------------------
+%% Returns: ok|false
+%%----------------------------------------------------------------------
+check_row(_CellPos,undefined) ->
+    {error,{gridline,{row,undefined}}};
+check_row(CellPos,Row) ->
+    case ets:lookup(CellPos,{1,Row}) of
+	[] ->
+	    {error,{gridline,row_outside_range,Row}};
+	[{_,Item}] ->
+	    case Item#item.line_id of
+		free -> ok;
+		_    ->
+		    {error,{gridline,row_is_occupied,Row}}
+	    end
+    end.
+
+%%----------------------------------------------------------------------
+%% s => text item
+%% p => rect item
+%%----------------------------------------------------------------------
+option(Option, _Gstkid, _TkW, DB,_) ->
+    case Option of
+	{{bg,_Item}, Color} -> {p,[" -f ", gstk:to_color(Color)]};
+	{{text,_Item},Text} -> {s, [" -te ", gstk:to_ascii(Text)]};
+	{{fg,_Item},Color} -> {sp,{[" -fi ", gstk:to_color(Color)],
+				  [" -outline ", gstk:to_color(Color)]}};
+	{{font,_Item},Font} -> {s,[" -font ",gstk_font:choose_ascii(DB,Font)]};
+	_ -> invalid_option
+    end.
+
+%%----------------------------------------------------------------------
+%% Is always called.
+%% Clean-up my specific side-effect stuff.
+%%----------------------------------------------------------------------
+delete(DB, Gstkid) ->
+    Row = gstk_db:opt(DB,Gstkid,row),
+    gstk_db:delete_widget(DB, Gstkid),    
+    {Gstkid#gstkid.parent, Gstkid#gstkid.id, gstk_gridline,[Gstkid, Row]}.
+
+%%----------------------------------------------------------------------
+%% Is called iff my parent is not also destroyed.
+%%----------------------------------------------------------------------
+destroy(DB, Lgstkid, Row) ->
+    Ggstkid = gstk_db:lookup_gstkid(DB,Lgstkid#gstkid.parent),
+    #gstkid{widget_data=State} = Ggstkid,
+    config_line(DB,Ggstkid,Lgstkid,Row,
+		[{bg,gstk_db:opt(DB,Ggstkid,bg)},
+		 {fg,gstk_db:opt(DB,Ggstkid,fg)},{text,""}]),
+    Ncols = State#state.ncols,
+    update_cp_db(Ncols,Row,free,State#state.cell_pos).
+
+
+config(DB, Gstkid, Opts) ->
+    Pgstkid = gstk_db:lookup_gstkid(DB,Gstkid#gstkid.parent),
+    case {gs:val(row,Opts,missing),gstk_db:opt(DB,Gstkid,row)} of
+	{Row,Row} -> % stay here...
+	    config_line(DB,Pgstkid,Gstkid,Row,Opts);
+	{missing,Row} ->  % stay here...
+	    config_line(DB,Pgstkid,Gstkid,Row,Opts);
+	{NewRow,OldRow} ->
+	    config_line(DB,Pgstkid,Gstkid,OldRow,Opts),
+	    Ngstkid = gstk_db:lookup_gstkid(DB,Gstkid#gstkid.id),
+	    case move_line(NewRow,OldRow,DB,Pgstkid#gstkid.widget_data,Ngstkid) of
+		true -> 
+		    gstk_db:insert_opt(DB,Ngstkid,{row,NewRow}),
+		    ok;
+		{error,_Reason} -> ok
+	    end
+    end,
+    ok.
+
+%%----------------------------------------------------------------------
+%% Returns: true|false depending on if operation succeeded
+%%----------------------------------------------------------------------
+move_line(NewRow,OldRow,_DB,State,_Ngstkid) ->
+    case ets:lookup(State#state.cell_pos,{1,NewRow}) of
+	[] ->
+	    {error,{gridline,row_outside_grid,NewRow}};
+	[{_,#item{line_id=Lid}}] when Lid =/= free->
+	    {error,{gridline,new_row_occupied,NewRow}};
+	[{_,_NewItem}] ->
+	    #state{tkcanvas=TkW,ncols=Ncols,cell_pos=CP} = State,
+	    swap_lines(TkW,OldRow,NewRow,1,Ncols,CP),
+	    true
+    end.
+
+%%----------------------------------------------------------------------
+%% Purpose: swaps an empty newrow with a (oldrow) gridline
+%%----------------------------------------------------------------------
+swap_lines(TkW,OldRow,NewRow,Col,MaxCol,CellPos) when Col =< MaxCol ->
+    [{_,NewItem}] = ets:lookup(CellPos,{Col,NewRow}),
+    [{_,OldItem}] = ets:lookup(CellPos,{Col,OldRow}),
+    swap_cells(TkW,NewItem,OldItem),
+    ets:insert(CellPos,{{Col,NewRow},OldItem}),
+    ets:insert(CellPos,{{Col,OldRow},NewItem}),
+    swap_lines(TkW,OldRow,NewRow,Col+1,MaxCol,CellPos);
+swap_lines(_,_,_,_,_,_) -> done.
+
+swap_cells(TkW,#item{rect_id=NewRectId,text_id=NewTextId},
+	   #item{rect_id=OldRectId,text_id=OldTextId}) ->
+    Aorid = gstk:to_ascii(OldRectId),
+    Aotid = gstk:to_ascii(OldTextId),
+    Anrid = gstk:to_ascii(NewRectId),
+    Antid = gstk:to_ascii(NewTextId),
+    Pre = [TkW," coords "],
+    OldRectCoords = tcl2erl:ret_str([Pre,Aorid]),
+    OldTextCoords = tcl2erl:ret_str([Pre,Aotid]),
+    NewRectCoords = tcl2erl:ret_str([Pre,Anrid]),
+    NewTextCoords = tcl2erl:ret_str([Pre,Antid]),
+    gstk:exec([Pre,Aotid," ",NewTextCoords]),
+    gstk:exec([Pre,Antid," ",OldTextCoords]),
+    gstk:exec([Pre,Aorid," ",NewRectCoords]),
+    gstk:exec([Pre,Anrid," ",OldRectCoords]).
+
+%%----------------------------------------------------------------------
+%% Pre: {row,Row} option is taken care of.
+%%----------------------------------------------------------------------
+config_line(DB,Pgstkid,Lgstkid,Row,Opts) ->
+    #gstkid{widget_data=State, widget=TkW} = Pgstkid,
+    #state{cell_pos=CP,ncols=Ncols} = State,
+    Ropts = transform_opts(Opts,Ncols),
+    RestOpts = config_gridline(DB,CP,Lgstkid,Ncols,Row,Ropts),
+    gstk_generic:mk_cmd_and_exec(RestOpts,Lgstkid,TkW,"","",DB).
+
+%%----------------------------------------------------------------------
+%% Returns: non-processed options
+%%----------------------------------------------------------------------
+config_gridline(_DB,_CP,_Gstkid,0,_Row,Opts) ->
+    Opts;
+config_gridline(DB,CP,Gstkid,Col,Row,Opts) ->
+    {ColOpts,OtherOpts} = opts_for_col(Col,Opts,[],[]),
+    if
+	ColOpts==[] -> done;
+	true ->
+	    [{_pos,Item}] =  ets:lookup(CP,{Col,Row}),
+	    TkW = Gstkid#gstkid.widget,
+	    TextPre = [TkW," itemconf ",gstk:to_ascii(Item#item.text_id)],
+	    RectPre = [$;,TkW," itemconf ",gstk:to_ascii(Item#item.rect_id)],
+	    case gstk_generic:make_command(ColOpts,Gstkid,TkW,
+					  TextPre,RectPre,DB) of
+		[] -> ok;
+		{error,_Reason} -> ok;
+		Cmd -> gstk:exec(Cmd)
+	    end
+    end,
+    config_gridline(DB,CP,Gstkid,Col-1,Row,OtherOpts).
+
+opts_for_col(Col,[{{Key,Col},Val}|Opts],ColOpts,RestOpts) ->
+    opts_for_col(Col,Opts,[{{Key,Col},Val}|ColOpts],RestOpts);
+opts_for_col(Col,[Opt|Opts],ColOpts,RestOpts) ->
+    opts_for_col(Col,Opts,ColOpts,[Opt|RestOpts]);
+opts_for_col(_Col,[],ColOpts,RestOpts) -> {ColOpts,RestOpts}.
+
+%%----------------------------------------------------------------------
+%% {Key,{Col,Val}} becomes {{Key,Col},Val}
+%% {Key,Val} becomes {{Key,1},Val}...{{Key,Ncol},Val}
+%%----------------------------------------------------------------------
+transform_opts([], _Ncols) -> [];
+transform_opts([{{Key,Col},Val} | Opts],Ncols) ->
+    [{{Key,Col},Val}|transform_opts(Opts,Ncols)];
+transform_opts([{Key,{Col,Val}}|Opts],Ncols) when is_integer(Col) ->
+    [{{Key,Col},Val}|transform_opts(Opts,Ncols)];
+transform_opts([{Key,Val}|Opts],Ncols) ->
+    case lists:member(Key,[fg,bg,text,font]) of
+	true -> 
+	    lists:append(expand_to_all_cols(Key,Val,Ncols),
+			 transform_opts(Opts,Ncols));
+	false ->
+	    case lists:member(Key,[click,doubleclick,row]) of
+		true ->
+		    [{keep_opt,{Key,Val}}|transform_opts(Opts,Ncols)];
+		false ->
+		    [{Key,Val}|transform_opts(Opts,Ncols)]
+	    end
+    end;
+transform_opts([Opt|Opts],Ncols) ->
+    [Opt|transform_opts(Opts,Ncols)].
+
+expand_to_all_cols(Key,Val,1) ->
+    [{{Key,1},Val}];
+expand_to_all_cols(Key,Val,Col) ->
+    [{{Key,Col},Val}|expand_to_all_cols(Key,Val,Col-1)].
+		     
+
+read(DB, Gstkid, Opt) ->
+    Pgstkid = gstk_db:lookup_gstkid(DB,Gstkid#gstkid.parent),
+    gstk_generic:read_option(DB, Gstkid, Opt,Pgstkid).
+
+read_option({font,Column},Gstkid, _TkW,DB,Pgstkid) -> 
+    case gstk_db:opt_or_not(DB,Gstkid,{font,Column}) of
+	false -> gstk_db:opt(DB,Pgstkid,font);
+	{value,V} -> V
+    end;
+read_option({Opt,Column},Gstkid, TkW,DB,#gstkid{widget_data=State}) -> 
+    Row = gstk_db:opt(DB,Gstkid,row),
+    [{_pos,Item}] = ets:lookup(State#state.cell_pos,{Column,Row}),
+    Rid = gstk:to_ascii(Item#item.rect_id),
+    Tid = gstk:to_ascii(Item#item.text_id),
+    Pre = [TkW," itemcg "],
+    case Opt of
+	bg -> tcl2erl:ret_color([Pre,Rid," -f"]);
+	fg -> tcl2erl:ret_color([Pre,Tid," -fi"]);
+	text -> tcl2erl:ret_str([Pre,Tid," -te"]);
+	_ -> {bad_result, {Gstkid#gstkid.objtype, invalid_option, {Opt,Column}}}
+    end;
+read_option(Option,Gstkid,TkW,DB,Pgstkid) -> 
+    case lists:member(Option,[bg,fg,text]) of
+	      true -> read_option({Option,1},Gstkid,TkW,DB,Pgstkid);
+	      false -> gstk_db:opt(DB,Gstkid,Option,undefined)
+    end.
+
+update_cp_db(0,_Row,_,_) -> ok;
+update_cp_db(Col,Row,ID,CP) ->
+    [{_,Item}] = ets:lookup(CP,{Col,Row}),
+    ets:insert(CP,{{Col,Row},Item#item{line_id = ID}}),
+    update_cp_db(Col-1,Row,ID,CP).
+
+
+event(DB, GridGstkid, Etype, _Edata, [CanItem]) ->
+    State = GridGstkid#gstkid.widget_data,
+    #state{cell_pos=CP,cell_id=CIs,tkcanvas=TkW} = State,
+    case ets:lookup(CIs,CanItem) of 
+	[{_id,{Col,Row}}] ->
+	    [{_pos,Item}] =  ets:lookup(CP,{Col,Row}),
+	    case Item#item.line_id of
+		free -> ok;
+		Id   ->
+		    Lgstkid = gstk_db:lookup_gstkid(DB,Id),
+		    case gstk_db:opt_or_not(DB,Lgstkid,Etype) of
+			{value,true}  ->
+			    Txt = read_option({text,Col},Lgstkid,TkW,
+					      DB,GridGstkid),
+			    gstk_generic:event(DB,Lgstkid,Etype,dummy,
+					      [Col,Row,Txt]);
+			_ -> ok
+		    end
+	    end;
+	_ -> ok
+    end;
+event(_DB, _Gstkid, _Etype, _Edata, _Args) ->
+    ok.