⟦661657e4f⟧

TextFile

(* REGN2.PAS INCLUDE FILE *)

æ*******************************************************************å
æ*  purpose:            micellaneous utilities and commands.       *å
æ*******************************************************************å

PROCEDURE CURSOR(cursor_on:boolean);
begin
 if cursor_on then
  write(curon)
 else
  write(curoff); 
end;

FUNCTION KEY:char;  æ Allmost all keyboard inputs through this routine å 
var
 cch:char;
begin
 CURSOR(true);
 read(kbd,cch);
 KEY:=cch;
 CURSOR(false);
end;

PROCEDURE DELAY(antal:integer;var trykket:boolean);
var
 dcount:integer;
begin
 dcount:=0;
 while (dcount<antal) and not trykket do begin
  dcount:=dcount+1;
  trykket:=keypress;
 end; 
end;

æ Displayes a line in the bottom of the screen and higligts the listed å
æ characters                                                           å

PROCEDURE HIGHLIGHTMSG(indlin:str128);
var
 udlin1,udlin2:stringÆ128Å;
 tpos:byte;
begin
 udlin1:=indlin;
 udlin2:='';
 for tpos:=1 to len(udlin1) do begin
  if (udlin1ÆtposÅ in Æ'A'..'Å','0','?'Å) then
   udlin2:=udlin2+rvson+udlin1ÆtposÅ+rvsoff
  else
   udlin2:=udlin2+udlin1ÆtposÅ;
 end;
 write(udlin2);
end;

PROCEDURE MSG(s: anystring);
begin
 gotoxy(0,23);
 write(clreol);
 write(s,rvsoff,' ');
end;

PROCEDURE FLASH(x: integer; s: anystring;  blink: boolean);
var
 tasttrykket:boolean;
begin
 tasttrykket:=false;
 write(rvson);
 gotoxy(x,22);
 write(s);
 if blink then begin
  repeat
   gotoxy(x,22);
   blink:=not blink;
   if blink then write(rvson) else write(rvsoff);
   write(s);
   DELAY(pause,tasttrykket);
  until tasttrykket;
 end;
 write(rvsoff);
end;

FUNCTION UPCASE(nch:char):char;
begin
 if (ord(nch)>96) and (ord(nch)<127) then
  UPCASE:=chr(ord(nch)-32)
 else
  UPCASE:=nch;
end;

PROCEDURE AUTO;
begin
 autocalc:=not autocalc;
 if autocalc then
  FLASH(63,' Autoregn: TIL ',false)
 else
  FLASH(63,' Autoregn: FRA ',false);
end;

PROCEDURE GRID;
var
 i:integer;
 count:char;
begin
 write(clrhom,indicator,rvson);
 for count:='A' to fxmax do begin
  gotoxy(xposÆcountÅ,0);
  write(vline,'    ',count,'     ');
 end;
 gotoxy(0,1);
 for i:=1 to fymax do writeln(i:2);
 write(rvsoff);
 if autocalc then
  FLASH(63,' Autoregn: TIL ' ,false)
 else
  FLASH(63,' Autoregn: FRA ',false);
 FLASH(37,'  Tast  /  for kommando  ',false);
end;

PROCEDURE INIT;
var
 i: sheetindex;
 j: integer;
begin
 forladt:='A';repeteret:=false;
 errmessageÆ1Å:='Uoverenstemmelse i filtype';
 errmessageÆ2Å:='Filen findes ikke';
 errmessageÆ3Å:='Disketten er fuld';
 errmessageÆ4Å:='Fil forsvundet';
 errmessageÆ5Å:='Programfejl - kan ikke læses';
 errmessageÆ6Å:='Programfejl - kan ikke skrives';
 errmessageÆ7Å:='For mange åbne filer';
 errmessageÆ8Å:='Ukendt fejl';
 errmessageÆ9Å:='Fejl ved indlæsning af tal';
 errmessageÆ10Å:='Ukendt fejl';
 errmessageÆ11Å:='For stor fil';
 errmessageÆ12Å:='Fil uafsluttet';
 errmessageÆ13Å:='Disketten er fuld';
 errmessageÆ14Å:='Søgning udover kant af fil';
 errmessageÆ15Å:='Fil ikke åben';
 retning:=0;indicator:=pilh;
 slut:=false;
 for i:='A' to fxmax do begin
  for j:=1 to fymax do begin
   with sheetÆi,jÅ do begin
    cellstatus:=ÆtxtÅ;      æ all cells initiated with text attribut å
    contents:='';           æ all strings emty                       å  
    value:=0;               æ all values 0                           å
    dec:=2;                 æ default number of decimals             å
    fw:=normwidth;          æ all cells width = normwidth            å
   end;
  end;
 end;
 autocalc:=true;            æ autocalc is on                         å
 fx:='A'; fy:=1;            æ first field in upper left corner       å
end;

PROCEDURE CLEAR;
begin
 write(rvsoff);
 gotoxy(0,23); write(clreol);
 write(@7+' Slet dette regneark?  (J/N) ');
 repeat
  ch:=UPCASE(KEY);
 until ch in Æ'J','N'Å;
 write(ch);
 if ch='J' then begin
  INIT;
  GRID;
 end;
end;

PROCEDURE SKIFTTYPE(typenr:byte);
begin
 gotoxy(4,22);write(rvson);
 if typenr=0 then
  write('TEKST  ')
 else
  if typenr=1 then
   write('TAL:   ')
  else
   write('FORMEL:');
 write(rvsoff);    
end;

PROCEDURE FLASHTYPE;
begin
 with sheetÆfx,fyÅ do begin
  gotoxy(0,22);
  if fy<10 then
   write(fx,fy,'  ')
  else
   write(fx,fy:2,' ');
  if formula in cellstatus  then
   write('FORMEL: ')
  else
   if constant in cellstatus then
    write('TAL     ')
   else
    if txt in cellstatus then write('TEKST   ');
  gotoxy(0,23);write(rvsoff,clreol);
  if formula in cellstatus then write(contents);
 end;
end;

PROCEDURE GOTOCELL(gx: sheetindex; gy: integer);
begin
 with sheetÆgx,gyÅ do begin
  write(rvson);
  gotoxy(xposÆgxÅ,gy);
  write(copy(tom,1,fw));
  gotoxy(xposÆgxÅ,gy);
  if txt in cellstatus then
   write(contents)
  else begin
   if not (formula in cellstatus) then begin
    if dec>=0 then
     write(value:fw:dec)
    else
     write(value:fw);
   end else begin
    if onscreen in cellstatus then begin
     if dec>=0 then
      write(value:fw:dec)
     else
      write(value:fw);
    end;
   end;
  end;
  FLASHTYPE;
  gotoxy(xposÆgxÅ,gy);
 end;
 write(rvsoff);
end;

PROCEDURE LEAVECELL(fx:sheetindex;fy: integer);
begin
 with sheetÆfx,fyÅ do begin
  gotoxy(xposÆfxÅ,fy);
  write(rvsoff);
  if (txt in cellstatus) then begin
   if not (cellstatus*Æoverwritten,lockedÅ<>ÆÅ) then
    write(contents+copy(tom,1,fw-len(contents)));
  end else begin
   write(copy(tom,1,fw));
   gotoxy(xposÆfxÅ,fy);
   if onscreen in cellstatus then begin
    if dec>=0 then
     write(value:fw:dec)
    else
     write(value:fw);
   end else
    write(copy(points,1,fw));
  end;
 end;
end;

PROCEDURE UPDATE;
var
 ufx: sheetindex;
 ufy: integer;
begin
 GRID;
 for ufx:='A' to fxmax do
  for ufy:=1 to fymax do
   if sheetÆufx,ufyÅ.contents<>'' then LEAVECELL(ufx,ufy);
end;

PROCEDURE MOVEDOWN;
var
 startx: sheetindex;
 starty: integer;
begin
 retning:=1;indicator:=pilned;
 gotoxy(0,0);write(indicator);
 LEAVECELL(fx,fy);
 if forladt>fx then fx:=forladt;
 startx:=fx;starty:=fy;
 repeat
  fy:=fy+1;
  if fy>fymax then fy:=1;
  while (sheetÆfx,fyÅ.cellstatus*Æoverwritten,lockedÅ<>ÆÅ)
   and (fx>'A') do fx:=pred(fx);
 until (sheetÆfx,fyÅ.cellstatus*Æoverwritten,lockedÅ=ÆÅ)
  or ((fy=starty) and (fx=startx));
 GOTOCELL(fx,fy);
end;

PROCEDURE MOVEUP;
var
 startx: sheetindex;
 starty: integer;
begin
 LEAVECELL(fx,fy);
 if forladt>fx then fx:=forladt;
 startx:=fx;starty:=fy;
 repeat
  fy:=fy-1;
  if fy<1 then fy:=fymax;
  while (sheetÆfx,fyÅ.cellstatus*Æoverwritten,lockedÅ<>ÆÅ)
   and (fx>'A') do fx:=pred(fx);
 until (sheetÆfx,fyÅ.cellstatus*Æoverwritten,lockedÅ=ÆÅ)
  or ((fy=starty) and (fx=startx));
 GOTOCELL(fx,fy);
end;

PROCEDURE MOVERIGHT;
var
 startx: sheetindex;
 starty: integer;
begin
 retning:=0;indicator:=pilh;
 gotoxy(0,0);write(indicator);
 LEAVECELL(fx,fy);
 startx:=fx;starty:=fy;
 repeat
  if fx<fxmax then
   fx:=succ(fx)
  else begin
   fx:='A';
   fy:=fy+1;
   if fy>fymax then fy:=1;
  end;
 until (sheetÆfx,fyÅ.cellstatus*Æoverwritten,lockedÅ=ÆÅ)
  or ((fx=startx) and (fy=starty));
 forladt:=fx;
 GOTOCELL(fx,fy);
end;

PROCEDURE MOVELEFT;
var
 startx: sheetindex;
 starty: integer;
begin
 LEAVECELL(fx,fy);
 startx:=fx;starty:=fy;
 repeat
  if fx>'A' then
   fx:=pred(fx)
  else begin 
   fx:=fxmax;
   fy:=fy-1;
   if fy<1 then fy:=fymax;
  end;
 until (sheetÆfx,fyÅ.cellstatus*Æoverwritten,lockedÅ=ÆÅ)
  or ((fx=startx) and (fy=starty));
 forladt:=fx;
 GOTOCELL(fx,fy);
end;


type
 string3 = stringÆ3Å;

var
 filename: str14;
 line: stringÆ100Å;

FUNCTION EXIST(filen: anystring): boolean;
var
 f: file;
begin
 æ$i-å
 assign(f,filen);
 reset(f);
 æ$i+å
 if iores<>0 then EXIST:=false else EXIST:=true;
 close(f);
end;

PROCEDURE FORTRYDTEKST;
begin
 FLASH(37,'  Fortryd  -  Tast  ESC  ',false);
end;

PROCEDURE FJERNFLASH(xpos,tlen:byte);
begin
 FLASH(xpos,rvsoff+copy(tom,1,tlen),false);
end;

FUNCTION DISKVALG:char;
var
 sv,udisk:char;
 diskok:boolean;
begin
 FORTRYDTEKST;
 repeat
  diskok:=true;
  MSG(' Hvilket drev?  ');
  repeat
   udisk:=UPCASE(KEY);
  until udisk in Æ'A'..'P',escÅ;
  if udisk<>esc then write(udisk);
  if not (udisk in Æ'A','B',escÅ) then begin
   diskok:=false;
   FLASH(13,'  DREV '+udisk+': ????   J/N  '+@7,true);
   repeat
    sv:=UPCASE(KEY);
   until sv in Æ'J','N'Å;
   if sv='J' then diskok:=true;
   FJERNFLASH(13,23);
  end;
 until diskok;
 DISKVALG:=udisk;
end;

PROCEDURE GETFILENAME(xp:byte; var line: str14; filetype:string3);
begin
 line:='';
 FORTRYDTEKST;
 gotoxy(xp,23);write(clreol);
 repeat
  ch:=UPCASE(KEY);
  if ch in Æ'A'..'Z','_',':','0'..'9',return,venstre,delleft,escÅ then begin
   if ch in Ævenstre,delleftÅ then begin
    if len(line)>0 then delete(line,len(line),1);
    gotoxy(xp,23);write(clreol,line);
   end else begin
    if ch=esc then
     line:=''
    else begin
     write(ch);
     line:=line+ch;
    end; 
   end; 
  end;
 until (ch=return) or (ch=esc);
 if ch=return then delete(line,len(line),1);
 if pos(':',line)>0 then begin
  write(rvson,@7,'  UMULIGT ARKNAVN! - TRYK EN TAST ',rvsoff);
  ch:=KEY;ch:=@0;line:='';
 end;
 if line<>'' then line:=line+'.'+filetype;
 FJERNFLASH(37,25);
end;

PROCEDURE SAVE;
var
 udisk:char;
 i: sheetindex;
 j,fejl: integer;
 overskriv:boolean;
begin
 udisk:=DISKVALG;
 if udisk<>esc then begin
  DISKDIR(udisk,'????????ARK',false,'GEMTE ARK');
  repeat
   overskriv:=true;
   filename:='';
   MSG(' GEM:  Angiv arknavn:  ');
   GETFILENAME(23,filename,'ARK');
   if (filename<>'') then begin
    RESETDISK;
    assign(tekstfil,udisk+':'+filename);
    (*$I-*)
    reset(tekstfil);
    (*$I+*)
    fejl:=iores;
    if fejl=0 then begin
     MSG(@7+'ARKET: '+filename+' findes allerede! - Skal det overskrives? J/N ');
     repeat
      ch:=UPCASE(KEY);
     until ch in Æ'J','N'Å;
     write(ch);
     if ch='N' then overskriv:=false;
     LUK(1,fejl);
    end;
   end;
  until (filename='') or overskriv;
  if filename<>'' then begin
   MSG(' Et øjeblik... - Ark: '+filename+' gemmes ');
   assign(mcfile,udisk+':'+filename);
   (*$I-*)
   rewrite(mcfile);
   fejl:=iores;
   if fejl=0 then 
    for i:='A' to fxmax do begin
     j:=1;
     while (j<=fymax) and (fejl=0) do begin
      write(mcfile,sheetÆi,jÅ);
      fejl:=iores;
      j:=j+1;
     end;
    end;
   if fejl=0 then LUK(1,fejl);
   (*$I+*)
   if fejl>0 then begin
    MSG(@7+' FEJL VED SKRIVNING: '+errmessageÆfejlÅ+' - TRYK EN TAST ');
    ch:=KEY;
   end;
  end;
  UPDATE;
 end else
 GOTOCELL(fx,fy);
end;

PROCEDURE LOAD;
var
 udisk:char;
 fejl:integer;
begin
 udisk:=DISKVALG;
 if udisk<>esc then begin
  DISKDIR(udisk,'????????ARK',false,'GEMTE ARK');
  MSG(' HENT:  Angiv arknavn:  ');
  GETFILENAME(24,filename,'ARK');
  if (filename<>'') then
   if (not EXIST(udisk+':'+filename)) then
    repeat
     MSG(@7+' Intet ark: '+filename+'! - Skriv et andet arknavn: ');
     filename:='';
     GETFILENAME(52,filename,'ARK');
    until EXIST(udisk+':'+filename) or (filename='');
  if filename<>'' then begin
   MSG(' Et øjeblik... - Ark: '+filename+' hentes ');
   (*$I-*)
   assign(mcfile,udisk+':'+filename);
   reset(mcfile);
   fejl:=iores;
   if fejl=0 then begin
    for fx:='A' to fxmax do begin
     fy:=1;
     while (fy<=fymax) and (fejl=0) do begin
      read(mcfile,sheetÆfx,fyÅ);
      fejl:=iores;
      fy:=fy+1;
     end;
    end;
   end;
 æ  if fejl=0 then LUK(1,fejl);    å
   close(mcfile);
   (*$I+*)
   if fejl>0 then begin
    MSG(@7+' FEJL VED LÆSNING: '+errmessageÆfejlÅ+' - TRYK EN TAST ');
    ch:=KEY;
   end;
   fx:='A'; fy:=1;
  end;
  UPDATE;
 end else
 GOTOCELL(fx,fy);
end;

PROCEDURE PRINT;
var
 udisk:char;
 printer,overskriv:boolean;
 i:sheetindex;
 j,count,fejl,
 leftmargin: integer;
 p:stringÆ20Å;
begin
 FORTRYDTEKST;
 MSG(' UDSKRIFT:  På Printer eller Diskette?  P/D ');
 repeat
  ch:=UPCASE(KEY);
 until ch in Æ'P','D',escÅ;
 if ch=esc then
  udisk:=esc
 else
  write(ch);
 printer:=(ch<>'D');
 if not printer then udisk:=DISKVALG;
 if udisk<>esc then begin
  leftmargin:=1;
  if not printer then begin
   DISKDIR(udisk,'????????LST',false,'SKREVNE ARK');
   repeat
    overskriv:=true;
    filename:='';
    MSG(' UDSKRIFT: Angiv arknavn:  ');
    GETFILENAME(27,filename,'LST');
    if (filename<>'') then begin
     assign(tekstfil,udisk+':'+filename);
     (*$I-*)
     reset(tekstfil);
     fejl:=iores;
     (*$I+*)
     if fejl=0 then begin
      MSG(@7+'ARKET: '+filename+' findes allerede! - Skal det overskrives? J/N ');
      repeat
       ch:=UPCASE(KEY);
      until ch in Æ'J','N'Å;
      write(ch);
      if ch='N' then overskriv:=false;
      LUK(2,fejl);
     end;
    end;
   until (filename='') or overskriv;
   FJERNFLASH(37,25);
  end;
  if (filename<>'') or printer then begin 
   if printer then
    filename:='LST:'
   else
    filename:=udisk+':'+filename;
   MSG(' Udskrift på : ' + filename + '....');
   assign(tekstfil,filename);
   (*$I-*)
   rewrite(tekstfil);
   fejl:=iores;
   if fejl=0 then begin
    if printer then begin
     count:=1;
     while (count<=5) and (fejl=0) do begin
      count:=count+1;
      writeln(tekstfil);
      fejl:=iores;
     end;
    end;
    j:=1;
    while (j<=fymax) and (fejl=0) do begin
     eline:='';
     i:='A';
     for i:='A' to fxmax do begin
      with sheetÆi,jÅ do begin
       while (len(eline)-leftmargin<xposÆiÅ-3) do eline:=eline+' ';
       if (constant in cellstatus) or (formula in cellstatus) then begin
        if not (locked in cellstatus) then begin
         if dec>=0 then str(value:fw:dec,p) else str(value:fw,p);
         if (onscreen in cellstatus) or not (formula in cellstatus) then
          eline:=eline+p
         else
          eline:=eline+copy(tom,1,fw); 
        end;
       end else
        eline:=eline+contents;
      end; æ width å
     end; æ one line å
     for count:=1 to leftmargin do write(tekstfil,' ');
     writeln(tekstfil,eline);
     fejl:=iores;
     j:=j+1;
    end; æ end column å
    if fejl=0 then LUK(2,fejl);
    if printer then L_DETACH;
   end;
   (*$I+*)
   if fejl>0 then begin
    MSG(@7+' FEJL VED SKRIVNING: '+errmessageÆfejlÅ+' - TRYK EN TAST ');
    ch:=KEY;
   end;
  end;
  UPDATE;
 end else
 GOTOCELL(fx,fy);
end;
«eof»
DataMuseum.dk

CP/M

⟦661657e4f⟧ TextFile

Derivation

TextFile
