! STP_RECTANGLE.TPU                   
!       This module contains TPU code to implement rectanglar regions.
! It also contains some applications of those rectanglar regions.
! The resultant functions are:                        
!
!       EVE_RECTANGULAR_SELECT          select a rectangular region
!       EVE_RECTANGULAR_REMOVE          remove a rectangular selection
!       EVE_RECTANGULAR_INSERT_HERE     insert a rectangular block
!       EVE_RECTANGULAR_STORE_TEXT      store text of a rectangular region
!       EVE_RECTANGULAR_CHANGE_CASE     perform case inversion on rectangle
!       EVE_RECTANGULAR_TEXT_FILL       fill text into a rectangular region
!       EVE_NUMBER_LINES                number lines in a rectangular region
!	EVE_RECTANGULAR_EXECUTE_KEY	executes the specified keystroke
!					once for every line in the rectangular
!					region with that selection active.

procedure stp_rectangle_module_ident

return "V1.1";
endprocedure;

procedure stp_rectangle_module_init

rect_select_range := 0;
rect_select_range_line := 0;
rect_select_anchor := 0;
endprocedure;

!+
! This procedure drops a space at the current position if the current
! character is null so that any mark will be for an existing character.
! We really want a mark in a particular screen column.  In TPU,
! an EOL mark would move if the line were extended.  Also, we
! want to highlight the select point so we need a character there.
! The cursor is returned to its original position after the space is
! copied to the current position in the current buffer.
!-
PROCEDURE rect_PAD_BLANK
    IF MARK(NONE) = END_OF(CURRENT_BUFFER)
    THEN
	copy_text(" ");
	move_horizontal(-1)
    ELSE
	if current_character = ""
	then
	    copy_text(" ");
	    move_horizontal(-1);
	endif
    ENDIF
endprocedure;	! rect_pad_blank
!+
! This procedure returns a string of blank_count blank chars.
!-
PROCEDURE rect_blank_chars(blank_count)

  local
    blank_chars,
    oldlen,
    blanks_so_far;	! Length of blank char string so far

    IF blank_count = 0
    THEN
	RETURN ""
    ENDIF;

    blank_chars := " ";
    blanks_so_far := 1;
    loop
	exitif blanks_so_far >= blank_count;
	oldlen := LENGTH(blank_chars);
	blank_chars := blank_chars + blank_chars;
	blanks_so_far := blanks_so_far + oldlen;
    endloop;

    IF blanks_so_far > blank_count
    THEN
   	blank_chars :=
	    SUBSTR(blank_chars,1,blank_count)
    ENDIF;
    RETURN blank_chars
endprocedure;	! rect_blank_chars

!+
! This procedure returns the current mode for the current buffer
! and sets it to the value in NEW_MODE.
!-
PROCEDURE rect_SET_MODE(new_mode)

    rect_set_mode := get_info(current_buffer,"MODE");
    set(new_mode, current_buffer);
endprocedure;	! eveplus_set_mode

!+
!   Procedure to calculate the current column from the current offset, treating
!   TAB characters as up to 8 blanks.
!-
PROCEDURE rect_current_column

rect_current_column := get_info(current_buffer,"offset_column");
ENDPROCEDURE;

!+
!   Procedure to replace TAB characters by the appropriate number of
!   blanks on the current line, then pad the line out to a given length, if it
!   is shorter.  The routine assumes overstrike mode is in
!   effect.  It leave the current position at the beginning of the line.
!-
PROCEDURE rect_replace_tabs_with_blanks_and_pad(target_length)
LOCAL
    i,
    col,
    cur_length,
    saved_mode,
    new_line,
    eight_blanks;
    
     saved_mode := rect_set_mode(overstrike);

!+
!   Make sure we're not on the EOB marker.
!-
IF MARK(NONE) <> END_OF(CURRENT_BUFFER)
THEN
    IF INDEX(CURRENT_LINE, ASCII(9)) <> 0
    THEN
	new_line := '';
	eight_blanks := "        ";
	i := 1;
        col := 0;
	LOOP
  	    EXITIF i > LENGTH(CURRENT_LINE);
            IF SUBSTR(CURRENT_LINE,i,1) = ASCII(9)
	    THEN
                col := ((col + 8)/8)*8;
		new_line := new_line + SUBSTR(eight_blanks,1,col-LENGTH(new_line))
	    ELSE
		new_line := new_line + SUBSTR(CURRENT_LINE,i,1);
		col := col + 1
	    ENDIF;
	    i := i + 1
	ENDLOOP;

	MOVE_HORIZONTAL(-CURRENT_OFFSET);
	COPY_TEXT(new_line)
    ENDIF
ENDIF;

MOVE_HORIZONTAL(-CURRENT_OFFSET);

!+
!   Now pad out the line if we have to
!-
IF MARK(NONE) = END_OF(CURRENT_BUFFER)
THEN
    cur_length := 0
ELSE
    cur_length := LENGTH(CURRENT_LINE)
ENDIF;

IF cur_length < target_length
THEN
    MOVE_HORIZONTAL(cur_length);
    COPY_TEXT(rect_blank_chars(target_length - cur_length));
ENDIF;

MOVE_HORIZONTAL(-CURRENT_OFFSET);
SET(saved_mode,CURRENT_BUFFER)
ENDPROCEDURE;

!+
!      This procedure will move the cursor to the destination column specified
!      and will remove any tab characters along the way.
!-
procedure rect_move_to_column(dest_column)

if (dest_column < 1) then return endif;
rect_replace_tabs_with_blanks_and_pad(dest_column);
move_horizontal(dest_column-current_offset-1);

endprocedure;

!+
!      This routine will insert the number specified into the range
!      specified in an ascii format.  This routine obeys the current
!      mode setting.  If the buffer is in OVERSTRIKE mode, then numbers
!      will overstrike the existing text in the range.  Otherwise, the
!      numbers will insert the needed space.  The inserted numbers
!      are right justified and spaced filled to take up the full length
!      of the range specified.
!-
procedure rect_fill_range_with_number(range_to_fill,number,base)
                                              
local saved_pos;
                                    
on_error
    position(saved_pos);
    message(error);
    message("Serious Error with RECT_FILL_RANGE_WITH_NUMBER");
    abort;
endon_error

saved_pos := mark(none);
position(beginning_of(range_to_fill));           
copy_text(fao("!"+str(length(range_to_fill))+"UL",number+base));
position(saved_pos);                 
endprocedure;

!+
!	This routine will fill the range specified with the fill string
!	specified, padding spaces to the right to fill the range.  If
!	the fill string is shorter than the range then the string is 
!	turncated on output.  This routine obeys Insert/Overstrike modes.
!-
procedure rect_fill_range_with_string(range_to_fill,fill_string)

local saved_pos;

on_error
    position(saved_pos);
    message(error);
    message("Serious Error with RECT_FILL_RANGE_WITH_STRING");
    abort;
endon_error

saved_pos := mark(none);
position(beginning_of(range_to_fill));
copy_text(fao("!"+str(length(range_to_fill))+"AS",fill_string));
position(saved_pos);
endprocedure;

!+
!	This routine copies the selected range to the end of the
!	paste buffer.
!-
procedure rect_range_store_text(range_to_store)

local saved_pos;

position(beginning_of(range_to_store));
saved_pos := mark(none);
!+
!  first copy the selected range to the end of the insert here buffer
!  and move to the next line in the paste_buffer.
!-
position(end_of(paste_buffer));
copy_text(range_to_store);
move_horizontal(1);
position(saved_pos);
endprocedure;

!+
!      This routine removes the range of text specified and places
!      it in the INSERT HERE (paste_buffer) buffer.  It obeys the
!      current mode setting.  If the buffer is currently set to OVERSTRIKE
!      mode, then spaces are left where the text was.  Otherwise,
!      the space is filled by text to the right.  That text is moved
!      left to occupy the missing range.  This range is assumed to
!      only be on one line.  This will be the case if the range
!      is built by the RECT_RANGE_PROCESS routine.
!-
procedure rect_remove_range(range_to_remove)

rect_range_store_text(range_to_remove);
!+
!      If we are in OVERSTRIKE mode, then overstrike this range with
!      enough blank chars to fill it out.  Otherwise, just erase the range.
!-
if (get_info(current_buffer,"mode") = OVERSTRIKE) then
    rect_fill_range_with_string(range_to_remove," ");
else
    erase(range_to_remove);
endif;
endprocedure;

!+
!      This routine will process a rectangular range starting at
!      INP_START_MARK and ending at INP_END_MARK.  These two markers
!      specify the starting and ending lines and columns.  Adjustments
!      are made if the markers are in opposite order.  The processing
!      order is always from the top of the buffer to the bottom.  Both
!      markers are assumed to be in the same buffer.  Otherwise an error
!      will occur.  A range is created for each line in the rectangular
!      region.  The input parameter SEL_RANGE is set to that range
!      and the input parameter SEL_RANGE_LINE is set to the
!      current line in the rectangular selection that the processing
!      is currently active on.  These two variables are set for each
!      line in the rectangular region and then the routine pointed to
!      by the input parameter EXE_PROG is executed.
!
!      Execution will continue until the end of the rectangular region
!      is reached or an erorr has occurred.
!+
procedure rect_range_process(inp_start_mark,inp_end_mark,exe_prog;
                             sel_range, sel_range_line);

local saved_pos,start_col,end_col,temp,
      start_mark,end_mark,start_col_mark,end_col_mark,
      rect_range,rect_line;

on_error
    position(saved_pos);
    message(error);
    message("Serious error in RECT_RANGE_PROCESS");
    abort;
endon_error
                                      
rect_range := 0;
rect_line := 0;
saved_pos := mark(none);
!+
!	Get the start and end columns.  If start column is greater than
!	end column, swap them.  Also, if the start mark is after the
!	end mark then, start at the end mark and set the local end mark
!	to the start mark
!-
if (inp_start_mark > inp_end_mark) then
    start_mark := inp_end_mark;
    end_mark := inp_start_mark;
else
    start_mark := inp_start_mark;
    end_mark := inp_end_mark;
endif;
position(end_mark);
end_col := rect_current_column;
position(start_mark);
start_col := rect_current_column;
if (start_col > end_col) then
    temp := start_col;
    start_col := end_col;
    end_col := temp;
endif;
!+
!      Process lines until the end of the rectangular region is
!      reached or the end of the buffer is reached.  Output a status
!      message every 100 lines of processing.
!-
loop
    rect_move_to_column(start_col);
    start_col_mark := mark(none);
    rect_move_to_column(end_col);
    end_col_mark := mark(none);
    rect_range := create_range(start_col_mark,end_col_mark,none);
    if (sel_range <> tpu$k_unspecified)
    then
        if (sel_range = "SELECT")
        then
            eve$select_a_range(start_col_mark,end_col_mark)
        else
            sel_range := rect_range
        endif
    endif;
    rect_line := rect_line + 1;
    if (sel_range_line <> tpu$k_unspecified)
    then
       sel_range_line := rect_line
    endif;
    execute(exe_prog);
    if (((sel_range_line/100)*100) = sel_range_line) then
        message("Processed line "+str(sel_range_line));
    endif;
    move_vertical(1);
    move_horizontal(-current_offset);
    exitif mark(none) > end_mark;
endloop;
position(saved_pos);
if ((sel_range <> "SELECT") AND (sel_range <> tpu$k_unspecified)) 
then 
    sel_range := 0
endif;
endprocedure;

!+
!      This routine does not use the RECT_RANGE_PROCESS routine
!      to perform its work.  It performs a rectangular insert here
!      function.  It copies each line in the insert here buffer into
!      the current buffer starting in the line the cursor is currently
!      on and starting on that line and each subsequent line in the
!      column the cursor is currently in.  If the end of the buffer is
!      reached before the end of the insert here buffer is reached, lines
!      are appended to the end of the buffer to accomodate the insert here
!      buffer contents.
!
!      The cursor is returned to the starting point of this routine.
!-
procedure eve_rectangular_insert_here

local saved_pos,saved_pos1,saved_pos2,insert_text,
      saved_col;

on_error
   position(saved_pos1);
   message(error);
   message("Serious error in RECTANGULAR_INSERT_HERE");
   return;
endon_error

if (get_info(paste_buffer,"record_count") = 0) then
    message("No text to insert.");
    return
endif;
saved_pos1 := mark(none);
saved_pos := saved_pos1;
saved_col := rect_current_column;
position(beginning_of(paste_buffer));
rect_select_range_line := 0;
loop
    insert_text := current_line;
    move_vertical(1);
    saved_pos2 := mark(none);
    position(saved_pos);
    copy_text(insert_text);
    rect_select_range_line := rect_select_range_line + 1;
    if (((rect_select_range_line/100)*100) = rect_select_range_line) then
        message("Processed line "+str(rect_select_range_line));
    endif;
    exitif saved_pos2 >= end_of(paste_buffer);
    move_vertical(1);
    rect_move_to_column(saved_col);
    saved_pos := mark(none);
    position(saved_pos2);
endloop;
position(saved_pos1);
message(fao("!UL line!%S inserted in a rectangular form.",
        rect_select_range_line));
endprocedure;

!+
!	This routine "drops an anchor" at the start of a rectangular
!	selection region.  The end of the rectangular seletion is
!	the positon of the cursor when a rectangular function is activated. 
!	Executing this function when an "anchor" has already been dropped
!	will remove the anchor.
!-

procedure eve_rectangular_select

local curr_col;

if (rect_select_anchor <> 0) then
    rect_select_anchor := 0;
    message("Rectangular Selection canceled.");
else           
    rect_pad_blank;
    rect_select_anchor := mark(reverse);
    message(                        
    "Move cursor opposite corner of rectangular region to select text.");
endif;              
endprocedure;

!+
!	This routine is run at the end of a rectangular function.  It
!	removes the rectangular "anchor" and places the cursor where that
!	anchor was.  
!-

procedure rect_action_end

position(rect_select_anchor);
rect_select_anchor := 0;
endprocedure;

!+
!	This routine gets the start and end markers of a rectangular region.
!	It uses the rectangular "anchor" as a starting point and the current
!	cursor location as an ending point.  
!	It also will display a message saying "Start a rectanglar selection
!	first" if the anchor does not exist.
!-

procedure rect_get_markers(start_mark,end_mark)

if (rect_select_anchor = 0) then
    message("Start a Rectangular Selection first.");
    return(FALSE)
else 
    if (get_info(rect_select_anchor,"buffer") <> current_buffer) then
	message("Rectangular selection not started in this buffer.");
	return(FALSE)
    else 
	start_mark := rect_select_anchor;
	end_mark := mark(none);
	position(start_mark);
	return(TRUE)
    endif
endif;
endprocedure;
!+
!	This routine will process the input string on each line of
!	the rectanglar select region. 
!-
procedure rect_process(routine; pre_routine)

local m1,m2;

on_error
     message(error);
     message("Rectangle Processing halted.");
     abort;
endon_error;

if (not rect_get_markers(m1,m2)) then
    abort
endif;
if (pre_routine <> tpu$k_unspecified) then
   execute(pre_routine)
endif;
rect_range_process(m1,m2,routine,rect_select_range,rect_select_range_line);
rect_action_end;
endprocedure;
!+
!      This routine performs a rectangular remove function.  It will remove
!      the region of text in a rectangle starting at the start of the current
!      select range and ending at the current cursor position.  The removed
!      text is placed in the INSERT HERE buffer.  Each line in the rectangular
!      region is placed on a seperate line in the INSERT HERE buffer.
!
!      This routine uses the RECT_RANGE_PROCESS routine to drive the
!      RECT_REMOVE_RANGE routine for each range of the select region.
!-
procedure eve_rectangular_remove

rect_process("rect_remove_range(rect_select_range)","erase(paste_buffer)");
message(fao("!UL line!%S removed from the rectangular region.",
        rect_select_range_line));
rect_action_end;
endprocedure;

!+
!      This routine performs a rectangular store text function.  It will
!      store the text of the rectanglar region in the INSERT HERE buffer.
!
!      This routine uses the RECT_RANGE_PROCESS routine to drive the
!      RECT_RANGE_STORE_TEXT routine for each range of the select region.
!-
procedure eve_rectangular_store_text

rect_process("rect_range_store_text(rect_select_range)","erase(paste_buffer)");
message(fao("!UL line!%S copied from the rectangular region.",
        rect_select_range_line));
rect_action_end;
endprocedure;


!+
!      This routine operates just like the EVE_RECTANGULAR_REMOVE,
!      except it places numbers in the rectangular region instead of
!      removing the text.  It uses RECT_FILL_RANGE_WITH_NUMBER to
!      do the actual number filling.
!-
procedure eve_number_lines                                             

local rect_starting_num;

rect_starting_num := int(read_line("Start with what number? ")) - 1;
rect_process("rect_fill_range_with_number(rect_select_range,"+
             "rect_select_range_line,"+str(rect_starting_num)+")");
message(fao("Numbered !UL line!%S.",rect_select_range_line));
endprocedure;

!+                      
!	This routine fills the rectanglar region with the specified text.
!	Each line gets the text specified left-justified and space-padded.
!-
procedure eve_rectangular_text_fill

fill_text := read_line("Text to fill rectanglar region lines with: ");
rect_process("rect_fill_range_with_string(rect_select_range,"""+
             fill_text+""")");
message(fao("!UL line!%S were filled.",rect_select_range_line));
endprocedure;

!+
!      This routine is a good example of how any routine that          
!      operates on a range can be applied to a rectangular region.     
!                    
!      This routine will invert the case of all characters in the
!      currently selected rectangular region.
!-
procedure eve_rectangular_change_case

rect_process("change_case(rect_select_range,invert)");
endprocedure;

!+
!	This routine will execute a keystroke given on each line
!	of a given rectangular region.  The section of that line
!	which is inside the rectangle will be selected at the time
!	of the keystroke execution
!-
procedure eve_rectangular_execute_key

local m1,m2,keystroke;

if (not rect_get_markers(m1,m2)) then
    return
endif;
keystroke := eve$prompt_key ("Press key to execute on rectangular region: ");
if (eve$key_name(keystroke) = "DO") then 
    message("Rectangular Execute Key aborted.");
    return
endif;
rect_range_process(m1,m2,keystroke,"SELECT",rect_select_range_line);
message(fao("!UL line!%S processed with !AS",rect_select_range_line, 
        eve$key_name(keystroke)));
rect_action_end;
endprocedure;


eve$$require ("eve$core");              ! Build dependencies
eve$$require ("eve$edit");
eve$$require ("eve$format");
eve$$require ("eve$extend");
eve$$require ("eve$edit");
eve$$require ("eve$advanced");
eve$$require ("eve$help");
eve$$require ("eve$edt");
!        
eve$$require ("stp_rectangle");