DataMuseum.dk

top - metrics - download

    Length: 10880 (0x2a80)
    Types: TextFile
    Names: »FORSIDE.PAS«

└─⟦456974178⟧ Bits:30002875 Pascal-bibliotek til tegning af streg-grafik på Piccoline
    └─⟦this⟧ »FORSIDE.PAS« 

TextFile

PROGRAM FORSIDE(*$C-*);  (* Compileres til: p forside,100,,FFF,FFF *)

(* Program til fremvisning af et PUF-billede med efterfølgende opstart af *)
(* en CMD-fil.                                                            *)
(* Hvis man ønsker, at det efterfølgende program skal startes op i grafik-*)
(* tilstanden, skal følgende konstant cont_grafik laves TRUE              *)

(*$I PUFGSX.PAS*)

const
 cont_grafik:boolean=FALSE;

type
 str2=stringÆ2Å;str15=stringÆ15Å;str39=stringÆ39Å;
 bilrec=record
  kommando:byte;
  k:arrayÆ1..2Å of integer;
 end;
const
 tom:stringÆ80Å='                                                                                ';
 mmax=9999;
var
 regs:record
  ax,bx,cx,dx,bp,si,di,ds,es,flags:integer;
 end;
 billednavn,programnavn:str15;
 buetal:arrayÆ1..36,1..2Å of real;
 tmin,tmax,xer,yer,xspring,yspring,ymax,xmax,screenstart:integer;
 nyfil:file;
 sv,ch:char;
 fpoints,step,nutype,ox,oy,nx,ny:integer;
 chw,chh,clw,clh:integer;
 tline:str39;
 corners:arrayÆ1..1000Å of coor;
 base:arrayÆ1..1500Å of bilrec;
 billedfil:file of bilrec;
 ll,nu,count:byte;
 contour,fillgem:boolean;
 xy:arrayÆ1..37Å of coor;
 tmpstep,iofejl,i,txfakt,txretn,txwidth,txshadow,txcolour,fcolour,lcolour:integer;
 nvm:^byte;
 screen22,afbrudt,fejlform:boolean;
  
PROCEDURE LINE(x1,y1,x2,y2:integer);
begin
 xyÆ1Å.x:=x1;
 xyÆ1Å.y:=y1;
 xyÆ2Å.x:=x2;
 xyÆ2Å.y:=y2;
 POLYLINE(2,xy);
end;

PROCEDURE BOX(x1,y1,x2,y2:integer);
begin
 xyÆ1Å.x:=x1;
 xyÆ1Å.y:=y1;
 xyÆ2Å.x:=x1;
 xyÆ2Å.y:=y2;
 xyÆ3Å.x:=x2;
 xyÆ3Å.y:=y2;
 xyÆ4Å.x:=x2;
 xyÆ4Å.y:=y1;
 xyÆ5Å:=xyÆ1Å;
 POLYLINE(5,xy);
end;

PROCEDURE RUND(x1,y1,x2,y2:integer);
var
 bue,radius:integer;
 xt,yt,xt2,yt2:real;
begin
 xt:=x1/0.7;yt:=y1;xt2:=x2/0.7;yt2:=y2;
 radius:=round(sqrt(sqr(xt-xt2)+sqr(yt-yt2)));
 x2:=round(x1+radius*0.7);y2:=y1;
 xyÆ1Å.x:=x2;xyÆ1Å.y:=y2;
 for bue:=1 to 36 do begin
  xt:=x1+radius*buetalÆbue,1Å;
  yt:=y1+radius*buetalÆbue,2Å;
  if xt<=maxint then
   if xt<0 then
    xyÆ1+bueÅ.x:=0
   else
   xyÆ1+bueÅ.x:=round(xt)
  else
   xyÆ1+bueÅ.x:=maxint;
  if yt<=maxint then
   if yt<0 then
    xyÆ1+bueÅ.y:=0
   else
    xyÆ1+bueÅ.y:=round(yt)
  else
   xyÆ1+bueÅ.y:=maxint;
 end;
 POLYLINE(37,xy);
end;

PROCEDURE SKYGGESKRIFT(ox,oy:integer;tekst:str39);
var
 st,p1,p2:byte;
 sx,sy:integer;
 
 PROCEDURE TEGNFLADE(vx,vy:integer;bredde:byte;indepth:boolean);
 begin
  sx:=vx;
  for p1:=1 to bredde do begin
   sy:=vy;
   for p2:=1 to bredde do begin
    GTEXT(sx,sy,tekst);
    sy:=sy-yspring;
   end;
   sx:=sx-xspring;
   if indepth then vy:=vy-yspring;
  end;
 end;
 
begin
 if txshadow>0 then begin
  TEXTCOLOR(fcolour);
  TEGNFLADE(ox+(txwidth+txshadow-1)*xspring,oy+(txwidth+txshadow-1)*yspring,txwidth,false);
  TEGNFLADE(ox+(txshadow-1)*xspring,oy+((txwidth+txshadow-2)*yspring),txshadow,true);
  TEGNFLADE(ox+(txwidth+txshadow-2)*xspring,oy+(txshadow-1)*256,txshadow,true);
  TEXTCOLOR(txcolour);
 end;
 TEGNFLADE(ox+(txwidth-1)*xspring,oy+(txwidth-1)*yspring,txwidth,false);
end;

PROCEDURE PALETTE(klatnr,nufarve:integer);
var
 oldfarve,pil,red,green,blue:integer;
begin
 red:=0;green:=0;blue:=0;
 for pil:=1 to 4 do begin
  oldfarve:=nufarve;
  nufarve:=nufarve div 2;
  if (oldfarve-2*nufarve=1) then begin
   if pil=1 then blue:=1;
   if pil=2 then green:=1;
   if pil=3 then red:=1;
   if pil=4 then
    if red=1 then
     red:=red+500
    else
     if green=1 then
      green:=green+500
     else
      if blue=1 then blue:=blue+500;
  end;
 end;
 SETCOLOR(klatnr,red,green,blue);
end;

PROCEDURE SETUP;
begin
 fillgem:=false;contour:=false;txfakt:=tmin;txretn:=0;
 txwidth:=1;txshadow:=0;txcolour:=1;fcolour:=1;lcolour:=1;
 step:=0;fpoints:=0;
 PALETTE(0,0);
 PALETTE(1,4);
 PALETTE(2,2);
 PALETTE(3,1);
 LINECOLOR(1);LINETYPE(1);FILLCOLOR(1);FILLTYPE(1);
 TEXTCOLOR(1);CHARUPVEC(0);CHARHEIGHT(tmin*yspring,chw,chh,clw,clh);
end;

FUNCTION KEY:byte;
begin
 while keypress do read(kbd,ch);
 read(kbd,ch);
 if (ord(ch)>96) and (ord(ch)<127) then ch:=chr(ord(ch)-32);
 KEY:=ord(ch);
end;

PROCEDURE DISPLAY;
 
 PROCEDURE ESCTEST;
 var
  cch:char;
 begin
  if keypress then begin
   read(kbd,cch);
   afbrudt:=true;
  end;
 end;
 
 PROCEDURE REDRAW(first,last:boolean);
 var
  k1,k2,nutype:integer;
  
  PROCEDURE DRAWTO;
  begin
   nx:=baseÆtmpstepÅ.kÆ1Å;ny:=baseÆtmpstepÅ.kÆ2Å;
   LINE(ox,oy,nx,ny);
   if fillgem then begin
    fpoints:=fpoints+1;
    cornersÆfpointsÅ.x:=nx;cornersÆfpointsÅ.y:=ny;
   end;
   ox:=nx;oy:=ny;
  end;
  
  FUNCTION DSCRAMB(bnr:byte):str2;
  begin
   DSCRAMB:=chr(hi(baseÆtmpstepÅ.kÆbnrÅ))+chr(lo(baseÆtmpstepÅ.kÆbnrÅ));
  end;
  
 begin
  tmpstep:=0;
  while (tmpstep<step) and not afbrudt do begin
   tmpstep:=tmpstep+1;
   nutype:=baseÆtmpstepÅ.kommando;
   k1:=baseÆtmpstepÅ.kÆ1Å;k2:=baseÆtmpstepÅ.kÆ2Å;
   case nutype of
    0:begin (*PALETTE*)
      PALETTE(k1,k2);
     end;
    1:begin (*LINECOLOUR*)
      lcolour:=k1;
      LINECOLOR(lcolour);
     end;
    2:begin (*FILLCOLOUR*) 
      fcolour:=k1;
      FILLCOLOR(fcolour);
     end;
    3:begin (*TEGNCOLOUR*) 
      txcolour:=k1;
      TEXTCOLOR(txcolour);
     end;
    5:begin (*LINJETYPE*)
      LINETYPE(k1);
     end;
    6:begin (*FILLTYPE*)
      FILLTYPE(k1);
      FILLSTYLE(k2);
     end;
    7:begin (*TEGNTYPE*)
      txretn:=5*(hi(k1));
      txfakt:=lo(k1);
      txwidth:=hi(k2);
      txshadow:=lo(k2);
      CHARUPVEC(txretn*10);
      CHARHEIGHT(txfakt*yspring,chw,chh,clw,clh);
     end;
    20:begin (*STARTPOINT*)
      ox:=k1;oy:=k2;
      if fillgem then begin
       fpoints:=1;
       cornersÆfpointsÅ.x:=ox;cornersÆfpointsÅ.y:=oy;
      end;
     end;
    21:DRAWTO;
    30,40,50:begin (*POLYGON/BOX/CIRKEL - BEGYND*)
      fillgem:=(k1=1);
      contour:=(fillgem and (k2=1));
     end;
    31:begin (*POLYGONSLUT*)
      if fillgem then begin
       POLYFILL(fpoints,corners);
       if contour then POLYLINE(fpoints,corners);
       fillgem:=false;contour:=false;fpoints:=0;
      end;
     end;
    41,51:begin (*BOXSLUT/CIRKELSLUT*)
      nx:=k1;ny:=k2;
      if nutype=41 then begin
       BOX(ox,oy,nx,ny);
       fpoints:=5;
      end else begin
       RUND(ox,oy,nx,ny);
       fpoints:=37;
      end;
      if fillgem then begin
       POLYFILL(fpoints,xy);
       if contour then POLYLINE(fpoints,xy);
       fillgem:=false;contour:=false;
      end;
      ox:=nx;oy:=ny;
     end;
    60,70:begin (*SKRIVSTRENG/KOMMENTAR*)
      ox:=k1;oy:=k2;
      tmpstep:=tmpstep+1;
      ll:=baseÆtmpstepÅ.kommando;
      tline:=DSCRAMB(1)+DSCRAMB(2);
      nu:=4;
      while (nu<ll) and (tmpstep<mmax) do begin
       tmpstep:=tmpstep+1;
       tline:=tline+chr(baseÆtmpstepÅ.kommando)+DSCRAMB(1)+DSCRAMB(2);
       nu:=len(tline);
      end;
      if nutype=60 then begin
       tline:=copy(tline,1,ll);
       if txwidth>1 then
        SKYGGESKRIFT(ox,oy,tline)
       else
        GTEXT(ox,oy,tline);     
      end;
     end;
    61,71:begin (*SLUTTEKST/SLUTKOMMENTAR*)
     end;
   otherwise
   end;
   ESCTEST;
  end;
 end;

 PROCEDURE HENTFIL;
 var
  fejlnum:str2;
 begin
  (*$I-*)
  (* Sets file attribut UNLOCKED *)
  memÆseg(billedfil):ofs(billedfil)+17Å:=memÆseg(billedfil):ofs(billedfil)+17Å+128;
  reset(billedfil);
  iofejl:=iores;
  if iofejl=0 then begin
   SETUP;
   while not (eof(billedfil) or afbrudt) and (iofejl=0) do begin
    step:=step+1;
    read(billedfil,baseÆstepÅ);
    iofejl:=iores;
    ESCTEST;
   end;
   if iofejl=0 then begin
    regs.cx:=16;
    regs.ds:=seg(billedfil);
    regs.dx:=ofs(billedfil)+12;
    swint(224,regs);(* close(billedfil); *)
    iofejl:=iores;
    if (iofejl=0) and not afbrudt then REDRAW(true,true);
   end;
  end;
  if iofejl<>0 then begin
   PALETTE(2,10);
   str(iofejl,fejlnum);
   gotoxy(2,12);
   write(rvson,' FEJL '+fejlnum+' I FORSIDE-BILLEDET "'+billednavn+'.PUF" ',rvsoff);
  end;
  (*$I+*)
 end;

begin (* DISPLAY *)
 assign(billedfil,billednavn+'.PUF');
 HENTFIL;
end;

PROCEDURE BUEINIT;
var
 bue:integer;
begin
 for bue:=1 to 36 do begin
  buetalÆbue,1Å:=0.7*cos(10*bue*pi/180);
  buetalÆbue,2Å:=sin(10*bue*pi/180);
 end;
end;

PROCEDURE FINDSCREEN;
begin
 screen22:=false;
 screenstart:=$D000;
 regs.cx:=109;
 regs.dx:=4;
 swint(224,regs);
 regs.ax:=3;
 swint($28,regs);
 nvm:=ptr(regs.es,regs.si+53);
 if (nvm^=0) then begin (* PARTNER CPU *)
  screen22:=true;
  screenstart:=$F000;
 end else begin (* PICCOLINE CPU *)
  regs.ax:=4;
  swint($28,regs);
  nvm:=ptr(regs.es,regs.si+18);
  if (nvm^>=2) or (nvm^=3) then screen22:=true; (* 22kHz screen *)
 end;
 if screen22 then begin
  xmax:=719;ymax:=351;
 end else begin
  xmax:=559;ymax:=255;
 end;
end;

PROCEDURE HENTNAVNE;
var
 packline:arrayÆ1..2Å of stringÆ10Å;
 pil,pil2,packnr:byte;
 tegn:char;
begin
 fejlform:=false;
 packnr:=1;
 pil:=memÆdseg:$80Å;
 packlineÆ1Å:='';packlineÆ2Å:='';
 if (pil>0) and (pil<127) then begin
  for pil2:=2 to pil do begin
   tegn:=chr(memÆdseg:$80+pil2Å);
   if tegn in Æ',',' 'Å then
    packnr:=2
   else
    packlineÆpacknrÅ:=packlineÆpacknrÅ+chr(memÆdseg:$80+pil2Å);
  end;
  if (packlineÆ1Å='') or (packlineÆ2Å='') then
   fejlform:=true
  else begin
   billednavn:=packlineÆ1Å;
   programnavn:=packlineÆ2Å;
  end;
 end else
  fejlform:=true;
end;

begin (* MAIN *)
 HENTNAVNE;
 if not fejlform then begin
  FINDSCREEN;
  afbrudt:=false;
  write(@27'0');
  iofejl:=0;
  OPENWS(1);
  tmin:=wsptsoutÆ1Å.y;
  tmax:=wsptsoutÆ2Å.y;
  tmin:=tmin div 128;
  tmax:=tmax div 128;
  xer:=wsintoutÆ1Å;
  yer:=wsintoutÆ2Å;
  xspring:=round(maxint/xer);
  yspring:=round(maxint/yer);
  BUEINIT;
  DISPLAY;
  if not afbrudt then begin
   gotoxy(13,24);
   write('TRYK EN TAST');
   sv:=chr(KEY);
  end else begin
   gotoxy(7,23);
   write(' FORSIDETEGNING AFBRUDT ');
  end;
  if not cont_grafik then begin
   CLOSEWS;
   gotoxy(25,24);
  end else
   gotoxy(10,24);
  write(clreol,programnavn+' STARTES ');
  assign(nyfil,programnavn+'.CMD');
  (*$I-*)
  execute(nyfil);
  iofejl:=iores;
  if iofejl>0 then begin
   if cont_grafik then CLOSEWS;
   gotoxy(0,23);
   write(@27'1KAN IKKE FINDE FILEN "'+programnavn+'.CMD"');
  end;
 end else begin
  write(alloff);
  gotoxy(0,23);
  writeln(clreol);
  writeln('Programmet FORSIDE bør startes med navnet på et PUF-billede');
  writeln('og navnet på den CMD-fil, der ønskes startet.');
  writeln('F. eks.:   FORSIDE HANEGAL FARM  eller FORSIDE HANEGAL,FARM');
  writeln('Herved vises billedet HANEGAL.PUF og dernæst startes programmet FARM.CMD');
 end;
end.
«eof»