Crawly Crypt Collection 1/crawlyvol1.bin/apps/spread/opusprg/opussrc/p.pas

Pascal/Delphi Source File | 1988-05-12 | 28KB | 674 lines

{$M+}
{$E+}

PROGRAM Mock;

{$I i:\opus.i}
{$I i:\gctv.inc}

{$I i:\globsubs.def}
{$I i:\gemsubs.def}
{$I i:\auxsubs.def}
{$I i:\vdi_aes.def}
{$I d:\pascal\opus\xbios.def}
{$I d:\pascal\opus\gemdos.def}
{$I d:\pascal\opus\stringfn.def}


PROCEDURE DO_PRINT ( s_row,f_row,s_col,f_col : INTEGER; hdl : INTEGER );
   { Prints either to disk or printer, depending on value of "hdl"
     above. 2 = serial port, 3 = parallel port, > 3 = disk }
   LABEL 222;
   TYPE PosRec = RECORD
                    start,
                    stop       : INTEGER
                 END;
       PosType = ARRAY [1..100] OF PosRec;
   VAR i,j,work_cols,max_cols,max_lines,line_count,
       page_num,start_row,end_row,start_col,end_col,
       cells_per_line,top_pos,bottom_pos,
       pos_in_line,pos_in_cell,a,b,c,d               : INTEGER;
       a_long                                        : LONG_INTEGER;
       title_1_flag,title_2_flag,
       head_flag,foot_flag                           : BOOLEAN;
       out_line,title_1,title_2                      : STR255;
       c_str                                         : C_STR255;
       positions                                     : PosType;
       line_desc                                     : LineOpArray;
       ptr                                           : CellPtr;

   FUNCTION TOS_Write ( handle     : INTEGER;
                        n          : LONG_INTEGER;
                        VAR buffer : C_STR255 ) : LONG_INTEGER;
      GEMDOS($40);

   PROCEDURE DISPLAY_PAGE_NUM ( first : BOOLEAN );
      VAR temp : STR10;
      BEGIN
          Hide_Mouse;
          int_to_string(page_num,temp);
          WHILE LENGTH(temp) < 4 DO
             temp := CONCAT(temp,' ');
          Set_Text(page_ptr,pagenum,temp,s10,4);
          IF first THEN BEGIN
             Form_Center(page_ptr,a,b,c,d);
             Form_Dial(0,a,b,c,d,a,b,c,d);
             Obj_Draw(page_ptr,Root,Max_Depth,a,b,c,d)
          END
          ELSE
             Obj_Draw(page_ptr,pagenum,Max_Depth,a,b,c,d);
          Show_Mouse
      END; { DISPLAY_PAGE_NUM }

   FUNCTION PRINTER_READY : BOOLEAN;
      BEGIN
          IF port = Centronics THEN
             IF PrtOut_Status = $FFFF THEN
                printer_ready := TRUE
             ELSE
                printer_ready := FALSE
          ELSE IF AuxOut_Status = $FFFF THEN
             printer_ready := TRUE
          ELSE
             printer_ready := FALSE
      END; { PRINTER_READY }

   FUNCTION GET_EXIT_KEY : BOOLEAN;
      { ESC is the exit key while printing }
      VAR event,d,key : INTEGER;
      BEGIN
          get_exit_key := FALSE;
          event := Get_Event (E_KeyBoard|E_Timer,0,0,0,0,FALSE,0,0,0,0,
                               FALSE,0,0,0,0,msg_area,key,d,d,d,d,d);
          IF (event & E_KeyBoard) <> 0 THEN
             IF key = $011B THEN BEGIN
                Set_Mouse(M_Arrow);
                IF Do_Alert('[3][REALLY quit printing?| ][ No | Yes ]',2)=2
                THEN
                   get_exit_key := TRUE
                ELSE
                   Set_Mouse(M_Bee)
             END
      END; { GET_EXIT_KEY }

   PROCEDURE SET_UP;
      BEGIN
          IF hdl = port THEN
             WHILE (NOT printer_ready) DO BEGIN
                out_line := CONCAT('[1][Printer does not respond.|' ,
                                       'Please check connections and|' ,
                                       'power...][ Cancel | Retry ]');
                IF Do_Alert(out_line,2) = 1
                   THEN GOTO 222
             END
      END; { SET_UP }

   PROCEDURE JUSTIFY ( VAR what      : STR255;
                           just      : VDI_Just;
                           len       : INTEGER );
      VAR what_len,text_pos : INTEGER;
          temp              : STR255;
      BEGIN
          what_len := LENGTH(what);
          CASE just OF
             VDI_Left : ; { assume that strings are left-justified as default }
             VDI_Center : BEGIN
                text_pos := (len-what_len) DIV 2;
                StringStr(' ',text_pos,temp);
                what := CONCAT(temp,what)
             END;
             VDI_Right : BEGIN
                text_pos := len-what_len;
                StringStr(' ',text_pos,temp);
                what := CONCAT(temp,what)
             END
          END
      END; { JUSTIFY }

   PROCEDURE PARSE (     source : STR255;
                     VAR dest   : STR255 );
      { evaluates header/footers & returns a string suitable for output
        to the printer  }
      VAR i,j,left_pos,center_pos,right_pos,carat  : INTEGER;
          left,center,right                        : STR255;
          operator                                 : CHAR;
      PROCEDURE INSERT_DATE ( VAR what : STR255 );
         VAR month,day,year           : INTEGER;
             temp1,temp2,temp3        : STR10;
             temp                     : STR255;
         BEGIN
             Get_Date(month,day,year);
             int_to_string(month,temp1);
             IF LENGTH(temp1) = 1 THEN
                temp1 := CONCAT('0',temp1);
             int_to_string(day,temp2);
             IF LENGTH(temp2) = 1 THEN
                temp2 := CONCAT('0',temp2);
             int_to_string(year,temp3);
             DELETE(temp3,1,2); { get rid of "19" }
             temp := CONCAT(temp1,'/',temp2,'/',temp3);
             IF carat > LENGTH(what) THEN
                what := CONCAT(what,temp)
             ELSE
                INSERT(temp,what,carat)
         END; { INSERT_DATE }
      PROCEDURE INSERT_FILE_NAME ( VAR what : STR255 );
         VAR temp : STR255;
         BEGIN
             IF current_file = '' THEN
                temp := 'Unnamed'
             ELSE
                temp := current_file;
             IF carat > LENGTH(what) THEN
                what := CONCAT(what,temp)
             ELSE
                INSERT(temp,what,carat)
         END;
      PROCEDURE INSERT_PAGE ( VAR what : STR255 );
         BEGIN
             int_to_string(page_num,temp);
             IF carat > LENGTH(what) THEN
                what := CONCAT(what,temp)
             ELSE
                INSERT(temp,what,carat)
         END;
      PROCEDURE INSERT_TIME ( VAR what : STR255 );
         VAR hours,mins,secs : INTEGER;
             temp1,temp2     : STR10;
             temp            : STR255;
         BEGIN
             Get_Time(hours,mins,secs);
             int_to_string(hours,temp1);
             IF LENGTH(temp1) = 1 THEN
                temp1 := CONCAT('0',temp1);
             int_to_string(mins,temp2);
             IF LENGTH(temp2) = 1 THEN
                temp2 := CONCAT('0',temp2);
             temp := CONCAT(temp1,':',temp2);
             IF carat > LENGTH(what) THEN
                what := CONCAT(what,temp)
             ELSE
                INSERT(temp,what,carat)
         END; { INSERT_TIME }
      PROCEDURE EVAL_OP ( operator : CHAR; VAR what : STR255 );
         BEGIN
             CASE operator OF
                'd' : insert_date(what);
                'f' : insert_file_name(what);
                'p' : insert_page(what);
                't' : insert_time(what)
             END
         END; { EVAL_OP }
      PROCEDURE EXPAND ( VAR what : STR255; endchar1,endchar2 : CHAR );
         BEGIN
             LOOP
                carat := POS('^',what);
                EXIT IF carat = 0;
                DELETE(what,carat,1);
                IF (what[carat] = endchar1) OR (what[carat]=endchar2) THEN
                   DELETE ( what,carat,LENGTH(what)-carat+1 )
                ELSE BEGIN
                   operator := what[carat];
                   DELETE(what,carat,1);
                   eval_op(operator,what)
                END
             END
         END; { EXPAND }
      BEGIN { PARSE }
          left := '';
          center := '';
          right := '';
          left_pos := POS('^l',source);
          center_pos := POS('^c',source);
          right_pos := POS('^r',source);
          IF (
               (left_pos = 0) AND (center_pos = 0) AND (right_pos = 0)
             ) OR
             (
               (center_pos = 0) AND (left_pos <> 1) AND (right_pos <> 1)
             ) THEN
             center_pos := -1; { because the default is centered }
          IF center_pos <> 0 THEN BEGIN
             center := COPY(source,center_pos+2,
                            LENGTH(source)-(center_pos+2)+1);
             expand(center,'l','r')
          END;
          IF left_pos <> 0 THEN BEGIN
             left := COPY(source,left_pos+2,
                          LENGTH(source)-(left_pos+2)+1);
             expand(left,'c','r')
          END;
          IF right_pos <> 0 THEN BEGIN
             right := COPY(source,right_pos+2,
                           LENGTH(source)-(right_pos+2)+1);
             expand(right,'l','c')
          END;
          { now combine the extracted left, center, and right strings into
            the final destination string; i.e. the header or footer }
          dest := left;
          center_pos := (max_cols-LENGTH(center)) DIV 2;
          IF (center <> '') AND
             (center_pos+LENGTH(center)-1 < max_cols) THEN BEGIN
             WHILE LENGTH(dest) < center_pos DO
                dest := CONCAT(dest,' ');
             dest := CONCAT(dest,center)
          END;
          right_pos := max_cols-LENGTH(right);
          IF right <> '' THEN BEGIN
             WHILE LENGTH(dest) < right_pos DO
                dest := CONCAT(dest,' ');
             dest := CONCAT(dest,right)
          END
      END; { PARSE }

   PROCEDURE PRINT_SHEET;
      LABEL 1;
      VAR i,j,line_count,row  : INTEGER;
          done                : BOOLEAN;
      FUNCTION CELLS_THAT_FIT : INTEGER; { fit on one line }
         VAR i,width,col_index : INTEGER;
         BEGIN
             width := col_width[start_col,spaces];
             col_index := start_col+1;
             WHILE (width+col_width[col_index,spaces] <= work_cols) AND
                   (col_index <= f_col) DO BEGIN
                   width := width+col_width[col_index,spaces];
                   col_index := col_index+1
             END;
             col_index := col_index-1;
             cells_that_fit := col_index-start_col+1
         END; { CELLS_THAT_FIT }
      PROCEDURE DESCRIBE_PAGE ( row : INTEGER );
         PROCEDURE TOP_OF_PAGE;
            VAR i : INTEGER;
            BEGIN
                line_desc[1] := LfOp;
                IF head_flag THEN
                   line_desc[2] := HeaderOp
                ELSE
                   line_desc[2] := LfOp;
                line_desc[3] := LfOp;
                line_desc[4] := LfOp;
                line_count := 4;
                IF page_num = 1 THEN
                   IF title_1_flag THEN BEGIN
                      line_count := line_count+1;
                      line_desc[line_count] := Title1Op;
                      IF title_2_flag THEN BEGIN
                         line_count := line_count+1;
                         line_desc[line_count] := Title2Op
                      END;
                      line_count := line_count+1;
                      line_desc[line_count] := LfOp;
                      line_count := line_count+1;
                      line_desc[line_count] := LfOp
                   END
                   ELSE
                      IF title_2_flag THEN BEGIN
                         line_count := line_count+1;
                         line_desc[line_count] := Title2Op;
                         line_count := line_count+1;
                         line_desc[line_count] := LfOp;
                         line_count := line_count+1;
                         line_desc[line_count] := LfOp
                      END;
                IF p_row_col THEN BEGIN
                   line_count := line_count+1;
                   line_desc[line_count] := RowColOp;
                   line_count := line_count+1;
                   line_desc[line_count] := LfOp
                END;
                line_count := line_count+1;
                top_pos := line_count { = beginning of data area }
            END; { TOP_OF_PAGE }
         PROCEDURE BOTTOM_OF_PAGE;
            BEGIN
                line_desc[65] := FFOp;
                IF foot_flag THEN
                   line_desc[64] := FooterOp
                ELSE
                   line_desc[64] := LfOp;
                line_desc[63] := LfOp;
                line_desc[62] := LfOp;
                bottom_pos := 61
            END; { BOTTOM_OF_PAGE }
         PROCEDURE BODY_OF_PAGE ( row : INTEGER );
            VAR i : INTEGER;
            BEGIN
                FOR i := top_pos TO bottom_pos DO BEGIN
                    IF row <= f_row THEN
                       line_desc[i] := DataOp
                    ELSE
                       line_desc[i] := LfOp;
                    row := row+1
                END
            END; { BODY_OF_PAGE }
         BEGIN { DESCRIBE_PAGE }
             top_of_page;
             bottom_of_page;
             body_of_page ( row );
         END; { DESCRIBE_PAGE }
      PROCEDURE CREATE_LINE ( VAR row : INTEGER );
         VAR f,i,j,k,width,temp_len,str_st,
             abs_border,tentative_pos,len,
             string_index,result,pos_index,
             additional,last_pos            : INTEGER;
             found                          : BOOLEAN;
             temp1                          : STR255;
             a                              : AssignedStatus;
         PROCEDURE STYLE ( what : PrinterSpecial );
            VAR k,len : INTEGER;
            BEGIN
                len := LENGTH(printer_codes[what]);
                { probably unnecessary to check for following but better
                  safe than sorry! }
                IF positions[i].start > LENGTH(out_line) THEN
                   out_line := CONCAT(out_line,printer_codes[what])
                ELSE
                   INSERT(printer_codes[what],out_line,positions[i].start);
                FOR k := i TO pos_index DO BEGIN
                    positions[k].start := positions[k].start+len;
                    positions[k].stop := positions[k].stop+len
                END;
                IF positions[i].stop > LENGTH(out_line) THEN
                   out_line := CONCAT(out_line,printer_codes[SUCC(what)])
                ELSE
                   INSERT(printer_codes[SUCC(what)],out_line,positions[i].stop);
                len := LENGTH(printer_codes[SUCC(what)]);
                FOR k := i TO pos_index DO BEGIN
                    IF k > i THEN
                       positions[k].start := positions[k].start+len;
                    positions[k].stop := positions[k].stop+len
                END
            END; { STYLE }
         BEGIN
             out_line := '';
             CASE line_desc[line_count] OF
                HeaderOp : parse(header,out_line);
                FooterOp : parse(footer,out_line);
                RowColOp : BEGIN
                   out_line := '      ';
                   FOR i := start_col TO end_col DO BEGIN
                       temp := col_name[i];
                       width := col_width[i,spaces];
                       justify(temp,VDI_Center,width);
                       WHILE LENGTH(temp) < width DO
                           temp := CONCAT(temp,' ');
                       out_line := CONCAT(out_line,temp)
                   END;
                   IF (hdl <= Centronics) AND (NOT condensed_print) THEN
                      out_line := CONCAT(printer_codes[BoldOn],out_line,
                                         printer_codes[BoldOff])
                END;
                DataOp  : IF row <= end_row THEN BEGIN
                   pos_in_line := 1;
                   last_pos := 0;
                   additional := 0;
                   IF p_row_col THEN BEGIN
                      int_to_string(row,temp);
                      justify(temp,VDI_Right,5);
                      IF (hdl <= Centronics) AND
                         (NOT condensed_print) THEN BEGIN
                         out_line := CONCAT(printer_codes[BoldOn],temp,
                                            printer_codes[BoldOff]);
                         pos_in_line := 7+LENGTH(printer_codes[BoldOn])+
                                          LENGTH(printer_codes[BoldOff]);
                         last_pos := pos_in_line-1;
                         additional := pos_in_line-7
                      END
                      ELSE BEGIN
                         out_line := temp;
                         pos_in_line := 7;
                         last_pos := 6
                      END
                   END;
                   abs_border := pos_in_line;
                   WHILE LENGTH(out_line) < 255 DO
                      out_line := CONCAT(out_line,' ');
                   pos_index := 1;
                   FOR i := start_col TO end_col DO BEGIN
                       width := col_width[i,spaces];
                       temp := '';
                       a := assigned(row,i,ptr);
                       IF (a <> Void) AND (a <> Desolate) THEN BEGIN
                          CASE ptr^.class OF
                             Val  : prepare_num(ptr,temp);
                             Labl : temp := ptr^.str^;
                             Expr : IF print_formulas THEN
                                       temp := ptr^.str^
                                    ELSE
                                       prepare_num(ptr,temp)
                          END;
                          str_st := 1;
                          len := LENGTH(temp);
                          CASE find_just(ptr) OF
                             VDI_Right : BEGIN
                                WHILE LENGTH(temp) < width DO BEGIN
                                   temp := CONCAT(' ',temp);
                                   str_st := str_st+1
                                END;
                                pos_in_cell := width-LENGTH(temp)
                             END;
                             VDI_Left : BEGIN
                                WHILE LENGTH(temp) < width DO
                                   temp := CONCAT(temp,' ');
                                pos_in_cell := 0
                             END;
                             VDI_Center : BEGIN
                                pos_in_cell := (width-LENGTH(temp)) DIV 2;
                                FOR j := 1 TO pos_in_cell DO BEGIN
                                    temp := CONCAT(' ',temp);
                                    str_st := str_st+1
                                END;
                                FOR j := LENGTH(temp) TO width DO
                                    temp := CONCAT(temp,' ');
                                pos_in_cell := (width-LENGTH(temp)) DIV 2
                             END
                          END; { CASE }
                          string_index := 1;
                          tentative_pos := pos_in_line+pos_in_cell;
                          WHILE tentative_pos < abs_border DO BEGIN
                             tentative_pos := tentative_pos+1;
                             string_index := string_index+1
                          END;
                          j := string_index;
                          k := 0;
                          found := FALSE;
                          WHILE j <= str_st+len-1 DO BEGIN
                             out_line[tentative_pos+k] := temp[j];
                             last_pos := tentative_pos+k;
                             IF (j >= str_st) AND (NOT found) THEN BEGIN
                                positions[pos_index].start := tentative_pos+k;
                                found := TRUE
                             END;
                             positions[pos_index].stop := tentative_pos+k+1;
                             j := j+1;
                             k := k+1
                          END
                       END { IF }
                       ELSE { not assigned }
                          WITH positions[pos_index] DO BEGIN
                             start := pos_in_line;
                             stop := pos_in_line+width-1
                          END;
                       pos_index := pos_index+1;
                       pos_in_line := pos_in_line+width
                   END; { FOR i }
                   WHILE LENGTH(out_line) > last_pos DO
                      DELETE(out_line,LENGTH(out_line),1);
                   WHILE LENGTH(out_line) > max_cols+additional DO
                      DELETE(out_line,LENGTH(out_line),1);
                   IF (hdl <= Centronics) AND (NOT condensed_print) THEN BEGIN
                      pos_index := pos_index-1;
                      j := start_col;
                      FOR i := 1 TO pos_index DO BEGIN
                          a := assigned(row,j,ptr);
                          IF (a <> Void) AND (a <> Desolate) THEN BEGIN
                             f := ptr^.format & style_mask;
                             IF f & bold_mask <> 0 THEN
                                style(BoldOn);
                             IF f & italic_mask <> 0 THEN
                                style(ItalicOn);
                             IF f & under_mask <> 0 THEN
                                style(UnderOn)
                          END;
                          j := j+1
                      END
                   END;
                   row := row+1
                END; { CASE DataOp }
                Title1Op :
                   IF (hdl <= Centronics) AND (NOT condensed_print) THEN
                      out_line := CONCAT(printer_codes[BoldOn],title_1,
                                         printer_codes[BoldOff])
                   ELSE
                      out_line := title_1;
                Title2Op :
                   IF (hdl <= Centronics) AND (NOT condensed_print) THEN
                      out_line := CONCAT(printer_codes[BoldOn],title_2,
                                         printer_codes[BoldOff])
                   ELSE
                      out_line := title_2;
                LfOp : ;
                FFOp : IF hdl <= Centronics THEN
                          out_line := printer_codes[PageTerm]
             END { CASE }
         END; { CREATE_LINE }
      BEGIN { PRINT_SHEET }
          start_row := s_row;
          start_col := s_col;
          end_row := f_row;
          end_col := f_col;
          done := FALSE;
          row := start_row;
          IF hdl <= Centronics THEN BEGIN
             FOR i := 1 TO LENGTH(printer_codes[Init]) DO
                 c_str[i] := printer_codes[Init,i];
             a_long := TOS_Write(hdl,LENGTH(printer_codes[Init]),c_str);
             IF a_long <> LENGTH(printer_codes[Init]) THEN BEGIN
                IF a_long >= 0 THEN
                   Form_Error(-10)
                ELSE
                   Form_Error(a_long);
                GOTO 1
             END;
             IF NOT draft_final THEN BEGIN
                FOR i := 1 TO LENGTH(printer_codes[Final]) DO
                   c_str[i] := printer_codes[Final,i];
                a_long := TOS_Write(hdl,LENGTH(printer_codes[Final]),c_str);
                IF a_long <> LENGTH(printer_codes[Final]) THEN BEGIN
                   IF a_long >= 0 THEN
                      Form_Error(-10)
                   ELSE
                      Form_Error(a_long);
                   GOTO 1
                END
             END;
             IF condensed_print THEN BEGIN
                FOR i := 1 TO LENGTH(printer_codes[Condensed]) DO
                   c_str[i] := printer_codes[Condensed,i];
                a_long := TOS_Write(hdl,LENGTH(printer_codes[Condensed]),
                                    c_str);
                IF a_long <> LENGTH(printer_codes[Condensed]) THEN BEGIN
                   IF a_long >= 0 THEN
                      Form_Error(-10)
                   ELSE
                      Form_Error(a_long);
                   GOTO 1
                END
             END
          END;
          display_page_num(TRUE);
          REPEAT
               cells_per_line := cells_that_fit;
               end_col := start_col+cells_per_line-1;
               IF end_col > f_col THEN
                  end_col := f_col;
               WHILE row <= f_row DO BEGIN  { this will do as many pages as }
                   display_page_num(FALSE); { are needed at 66 lines/page   }
                   describe_page(row);      { to print current columns      }
                   line_count := 1;
                   FOR i := 1 TO 65 DO BEGIN { this does a page }
                       IF get_exit_key THEN
                          GOTO 1;
                       create_line(row);
                       IF out_line <> printer_codes[PageTerm] THEN
                          out_line := CONCAT(out_line,printer_codes[LineTerm]);
                       FOR j := 1 TO LENGTH(out_line) DO
                           c_str[j] := out_line[j];
                       a_long := TOS_Write(hdl,LENGTH(out_line),c_str);
                       IF a_long <> LENGTH(out_line) THEN BEGIN
                          IF a_long >= 0 THEN
                             Form_Error(-10)
                          ELSE
                             Form_Error(a_long);
                          GOTO 1
                       END;
                       line_count := line_count+1
                   END;
                   page_num := page_num+1
               END;
               IF end_col = f_col THEN
                  done := TRUE
               ELSE BEGIN
                  row := start_row;
                  start_col := end_col+1
               END;
               IF get_exit_key THEN
                  done := TRUE;
          UNTIL done;
1:        Form_Dial(3,a,b,c,d,a,b,c,d)
      END; { PRINT_SHEET }
   BEGIN { DO_PRINT }
       max_lines := 66;
       page_num := 1;
       IF p_row_col THEN
          IF condensed_print THEN
             work_cols := con_chr_line-7
          ELSE
             work_cols := nl_chr_line-7
       ELSE IF condensed_print THEN
          work_cols := con_chr_line
       ELSE
          work_cols := nl_chr_line;
       IF condensed_print THEN
          max_cols := con_chr_line
       ELSE
          max_cols := nl_chr_line;
       IF p_title_1 <> '' THEN BEGIN
          title_1_flag := TRUE;
          title_1 := p_title_1;
          justify(title_1,VDI_Center,max_cols)
       END
       ELSE
          title_1_flag := FALSE;
       IF p_title_2 <> '' THEN BEGIN
          title_2_flag := TRUE;
          title_2 := p_title_2;
          justify(title_2,VDI_Center,max_cols)
       END
       ELSE
          title_2_flag := FALSE;
       IF header <> '' THEN
          head_flag := TRUE
       ELSE
          head_flag := FALSE;
       IF footer <> '' THEN
          foot_flag := TRUE
       ELSE
          foot_flag := FALSE;
       set_up;
       Set_Mouse(M_Bee);
       print_sheet;
222:   Set_Mouse(M_Arrow);
   END; { DO_PRINT }


BEGIN
END.