DataMuseum.dk

top - metrics - download

    Length: 11776 (0x2e00)
    Types: TextFile
    Names: »TEGN002.PAS«

└─⟦29e35ddf2⟧ Bits:30003931/CCPM_Tegn.imd Disketter indleveret af Steffen Jensen (Piccolo/Piccoline)
    └─⟦this⟧ »TEGN002.PAS« 

TextFile

 (* tegn002*)

procedure L_GET(var printernr:byte);(* hent printernummer *)     

begin
  with reg do begin
    cx := 164; (* l_get *)
  end;
  swint(224,reg);
  printernr:=reg.ax;  
end;

function tjeknavn(navn:streng8):boolean;

var
  slut            : boolean;

begin
  slut:=false;n:=0;
  repeat
      n:=n+1;
      if (navn(.n.) in (.'A'..'Z'.)) or (navn(.n.) in (.' '.)) then tjeknavn:=true
      else begin 
       if navn(.n.) in (.'1'..'9'.) then begin
         if n>1 then tjeknavn:=true 
       end else begin
         tjeknavn:=false;
         slut:=true;
       end;
      end;
      if n=len(navn) then slut:=true;
  until slut
end;
  (* ▶ac◀▶ac◀▶ac◀▶ac◀▶ac◀▶ac◀▶ac◀▶ac◀▶ac◀▶ac◀ *) 
function FilFindes(soegt_filnavn: streng20):boolean;

var
  program_fil        : file of char;

begin
  assign(program_fil,soegt_filnavn);
  (*$I- *) reset(program_fil) (*$I+ *);
  if (iores=2) then begin
    FilFindes:=false;
  end else begin
    FilFindes:=true;
  end;
  close(program_fil);
end;

function FilFindes_integer(soegt_filnavn: streng20):boolean;

var
  program_fil        : file of integer;

begin
  assign(program_fil,soegt_filnavn);
  (*$I- *) reset(program_fil) (*$I+ *);
  if (iores=2) then begin
    FilFindes_integer:=false;
  end else begin
    FilFindes_integer:=true;
  end;
  close(program_fil);
end;

procedure set_maerke(x,y,aktuel_farve:integer);

var
  maerke             : array(.1..1.) of coor;
  
begin
  maerke(.1.).x:=x;maerke(.1.).y:=y;
  markcolor(aktuel_farve);
  markscale(0);
  marktype(1);
  polymark(1,maerke);
end;
 
procedure dyt;

begin
  write(^G);
end;


procedure TaendStatuslinie;

begin
  write(@27'1');
end;  

procedure SlukStatuslinie;

begin
  write(@27'0');
end;  

procedure TaendCursor;

begin
  write(@27'e');
end;    

procedure SlukCursor;

begin  
  write(@27'f');
end;    

procedure SetFunkTast(ascii: byte; streng: streng20);

begin
  write(chr(27)+':'+chr(ascii)+streng+chr(0));
end;

procedure SetFunkTaster;

begin
end;

(* ▶ac◀▶ac◀▶ac◀▶ac◀▶ac◀▶ac◀▶ac◀▶ac◀▶ac◀▶ac◀ *)

procedure set_palette(colors:farvetyper);

begin
  for n:=0 to 3 do begin
    case colors(.n+1.) of
    '0':setcolor(n,0,0,0);      
    '1':setcolor(n,0,0,500);      
    '2':setcolor(n,0,500,0);      
    '3':setcolor(n,0,500,500);      
    '4':setcolor(n,500,0,0);      
    '5':setcolor(n,500,0,500);      
    '6':setcolor(n,500,500,0);      
    '7':setcolor(n,500,500,500);      
    '8':setcolor(n,0,0,0);      
    '9':setcolor(n,0,0,1000);      
    ':':setcolor(n,0,1000,0);      
    ';':setcolor(n,0,1000,1000);      
    '<':setcolor(n,1000,0,0);      
    '=':setcolor(n,1000,0,1000);      
    '>':setcolor(n,1000,1000,0);      
    '?':setcolor(n,1000,1000,1000);      
    end;
  end;  
end;  
  
  (* ▶ac◀▶ac◀▶ac◀▶ac◀▶ac◀▶ac◀▶ac◀▶ac◀▶ac◀▶ac◀ *)

procedure InputStreng(kolonne,linie,max_laengde:integer;
                      tegn_stoerrelse: integer;
                      fjern_mellemrum: boolean;
                      VAR streng:streng80);


const
  BACK_SPACE         = @8;
  RETURN_TAST        = @13;
  ESC_TAST           = @27;

  tegnsaet:set of char=(.' '..'ü'.);

var
  tegn               : char;
  streng_tegn        : array(.1..80.) of char;
  temp_streng        : streng80;
  i,xpos             : integer;

begin
  streng:='';
  for i:=1 to max_laengde do streng_tegn(.i.):=' ';
  xpos:=1;tegn:=chr(0);
  repeat
    gotoxy(kolonne-1+xpos,linie);
    TaendCursor;
    read(KBD,tegn);
    SlukCursor;
    
    if (tegn in tegnsaet) and (xpos<=max_laengde) then begin
      streng_tegn(.xpos.):=tegn;
      xpos:=xpos+1;
      write(tegn);
    end else begin
    if ((tegn=BACK_SPACE) and (xpos>1)) then begin
      for i:=xpos to max_laengde do begin
        streng_tegn(.(i-1).):=streng_tegn(.i.);
      end;
      streng_tegn(.max_laengde.):=' ';
      xpos:=(xpos-1);
      gotoxy(kolonne,linie);
      for i:=1 to max_laengde do write(streng_tegn(.i.));
    end ;
end;

  until ((tegn=RETURN_TAST) or (tegn=ESC_TAST));
  
  if (tegn=RETURN_TAST) then begin
    for i:=1 to max_laengde do streng:=streng+streng_tegn(.i.);
    i:=max_laengde;
    repeat
      if streng_tegn(.i.)=' ' then delete(streng,i,1);
      i:=i-1;
    until (streng_tegn(.i.)<>' ') or (i=1);

    if (tegn_stoerrelse=1) then begin
      for i:=1 to len(streng) do begin
        if (streng(.i.) in (.'A'..'^'.)) then begin
          streng(.i.):=chr(ord(streng(.i.))+32);
        end;
      end;
    end;
         
    if (tegn_stoerrelse=2) then begin
      for i:=1 to len(streng) do begin
        if (streng(.i.) in (.'a'..'ü'.)) then begin
          streng(.i.):=chr(ord(streng(.i.))-32);
        end;
      end;
    end;
         
    if fjern_mellemrum then begin
      temp_streng:=streng; streng:='';
      for i:=1 to len(temp_streng) do begin
        if (temp_streng(.i.)<>' ') then begin
          streng:=streng+temp_streng(.i.);
        end;
      end;
    end;
         
    if (fjern_mellemrum) or
       (tegn_stoerrelse=1) or (tegn_stoerrelse=2) then begin
      gotoxy(kolonne,linie);
      for i:=1 to max_laengde do write(' ');
      gotoxy(kolonne,linie);
      write(streng);
    end;

  end;

  if (tegn=ESC_TAST) then streng:=@27;

end;
 
procedure marker_farve(aktuel_farve:byte);

begin
  fillstyle(1);
  filltype(1);
  fillcolor(aktuel_farve);
  bar(31000,31700,32760,32760);
end;
  
procedure sletstatus;
 
 begin
   fillstyle(1);
   filltype(1);
   fillcolor(0);
   bar(0,29850,32760,31550);
   fillcolor(1);
   fillstyle(0);
   filltype(0);
   bar(0,29850,32760,31550);
 end;

procedure slethalvstatus;
 
 begin
   fillstyle(1);
   filltype(1);
   fillcolor(0);
   bar(8600,29850,32760,31550);
   fillcolor(1);
   fillstyle(0);
   filltype(0);
   bar(0,29850,32760,31550);
 end;
  
procedure ordre(streng1,streng2: strengtype);

var
  charw,charh,cellw,
  cellh              : integer;

begin
  sletstatus;
  textcolor(2);
  charheight(100,charw,charh,cellw,cellh);
  gtext(800,30350,streng1);
  gtext(13000,30350,streng2);
  fillcolor(1);
end;

type
  a8                 = array(.1..8.) of char;
  a3                 = array(.1..3.) of char;
  
var
  filnavne           : array(.1..80.) of streng8;
  diskok             : boolean;
  antal_filer        : integer;
  efternavn             : a3;

procedure HentFilnavne(diskdrev: char; fornavn: a8; efternavn: a3;
                       var disk_ok: boolean);
type
  fcb_type           = record
                         drive: byte;(* sættes til default=0 *)
                        f_navn: a8;(* filens 'fornavn'*)
                        e_navn: a3;(* filens 'efternavn' *)
                        extent: byte;(* extent-nr=0 *)
                        resten: array(.1..19.) of byte (* fyld *)
                       end;
var
  buffer             : array(.0..3.) of fcb_type;
  fcb                : fcb_type;
  i,fnr              : integer;
  temp_streng        : streng8;
  ombyttet           : boolean;

begin
  fcb.drive:=(ord(diskdrev)-64);
  for i:=1 to 8 do fcb.f_navn(.i.):=fornavn(.i.);
  for i:=1 to 3 do fcb.e_navn(.i.):=efternavn(.i.);
  fcb.extent:=ord('?');
  reg.cx:=45(* f_errmode='Return Error Mode'*);reg.dx:=$0FF;swint(224,reg);
  reg.cx:=51(* f_dmaseg *);reg.dx:=seg(buffer);swint(224,reg);
  reg.cx:=26(* f_dmaoff *);reg.dx:=ofs(buffer);swint(224,reg);
  reg.cx:=17(* f_sfirst *);reg.dx:=ofs(fcb);reg.ds:=seg(fcb);swint(224,reg);
  if (reg.ax=$01FF) then begin (* disk fejl *)
    disk_ok:=false;
  end else begin
    for i:=1 to 80 do filnavne(.i.):='';
    disk_ok:=true;
    fnr:=0;
    while ((reg.ax and $FF) <> $FF) do begin
      with reg,buffer(.ax and $0FF.) do begin
         fnr:=fnr+1;
         filnavne(.fnr.):='';
         for i:=1 to 8 do begin
           if f_navn(.i.)<>' ' then filnavne(.fnr.):=filnavne(.fnr.)+f_navn(.i.);
         end;  
         if fnr>=2 then begin
         for n:=1 to fnr-1 do begin
           if ((filnavne(.n.)=filnavne(.fnr.)) and (n<>fnr)) then fnr:=fnr-1;
         end;
         end;
       reg.cx:=18(* f_snext *);
      end;
      buffer(.0.).drive:=12;
      swint(224,reg)
    end;
    if (fnr=0) or (fnr=1) then begin
      if (fnr=0) then begin
        antal_filer:=0;
        ordre('DISK',' Fil(er) findes ikke ');
        rqlocator(1,xin,yin,status,term,xout,yout);
      end else begin
        antal_filer:=1;
      end;
    end else begin
      if (fnr>1) then begin
        antal_filer:=fnr;
        repeat
          ombyttet:=false;
          for fnr:=2 to antal_filer do begin
            if filnavne(.fnr.)<filnavne(.(fnr-1).) then begin
              temp_streng:=filnavne(.fnr.);
              filnavne(.fnr.):=filnavne(.(fnr-1).);
              filnavne(.(fnr-1).):=temp_streng;
              ombyttet:=true;
            end;
          end;
        until ombyttet=false;
      end;
    end;
  end;
end;

procedure skriv_diskdrev(diskdrev:char);

begin
  fillcolor(0);fillstyle(1);filltype(1);
  bar(17000,31700,22000,32670);
  textcolor(2);
  gtext(15000,31800,'DISK: '+diskdrev);
end;


procedure skaerm1;

begin
  sletstatus;
  textcolor(1);
  gtext(600,31800,'TEGN MED MUSEN');
  skriv_diskdrev(diskdrev);
  fillcolor(1);
  fillstyle(0);
  filltype(0);
  for n:=1 to 7 do
  begin
    bar((n-1)*4680,29850,n*4680,31550);
  end; 
  textcolor(2);
  if farveskaerm and (not skaerm22khz) then begin
    gtext(600,30350,'TEGN');
    gtext(5480,30350,'DISK');
    gtext(10160,30350,'KOPI');
    gtext(14200,30350,'PAPIR');
    gtext(19520,30350,'SLET');
    gtext(24000,30350,'SLUT') 
    end;
  if not farveskaerm and not skaerm22khz then begin   (* monokrom og 50Hz*)
    gtext(1200,30350,'TEGN');
    gtext(6080,30350,'DISK');
    gtext(10760,30350,'KOPI');
    gtext(15440,30350,'PAPIR');
    gtext(20120,30350,'SLET');
    gtext(24800,30350,'SLUT')
  end;
  if farveskaerm and skaerm22khz then begin   (* 60Hz*)
    gtext(1000,30350,'TEGN');
    gtext(5800,30350,'DISK');
    gtext(10260,30350,'KOPI');
    gtext(14640,30350,'PAPIR');
    gtext(19620,30350,'SLET');
    gtext(24300,30350,'SLUT')
  end;
  fillstyle(1);
  filltype(1);
  for n:=1 to 4 do
  begin
    fillcolor(n-1);
    bar((n-1)*1140+28200,30000,n*1140+28200,31400);
  end; 
end;

procedure spray(aktuel_farve,markoer:integer;var xin,yin:integer);


var
  linie              : array(.1..1.) of coor;
  tegn               : boolean;
  
begin
  writemode(1);
  inputmode(1,1);
  marktype(markoer);
  markcolor(aktuel_farve);
  tegn:=false;
  flag:=false;
  repeat
    rqlocator(2,xin,yin,status,term,xout,yout);
    if tegn
      then
        begin
          if contrl(.3.)>0 then begin     
                linie(.1.).x:=xout;
                linie(.1.).y:=yout;
                if aktuel_farve=0 then begin
                 writemode(2);
                 markcolor(1);
                 polymark(1,linie);
                 writemode(1);
                end;
                markcolor(aktuel_farve);
                polymark(1,linie);
                xin:=linie(.1.).x;yin:=linie(.1.).y;
          end;
        end;
    if (term=32) and (tegn=false)
      then
        begin
          tegn:=true;
          xin:=xout;yin:=yout;
          inputmode(1,2);
        end;
    if (term=34) or (term=33)
      then
        begin
          tegn:=false;
          inputmode(1,1);
        end;
    until term=33;
inputmode(1,1);
skaerm1;
end;  

«eof»