DataMuseum.dk

top - metrics - download

    Length: 12928 (0x3280)
    Types: TextFile
    Names: »VISPUF1.PAS«

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

TextFile

PROGRAM VISPUF1;
(*$i polypas *)
const
 dok_dis:stringmax='Fremvisning af PUF-BILLEDE';
 dok_init:stringmax=
 'INITIERINGSRUTINE AF PUF'@13@10' SKAL IKKE KALDES'@13@10'  initiering af cirkelrutine';
 dok_kald:stringmax=
'KALD DISPLAY MED: DISPLAY("filnavn")'@13@10'  filnavn er fornavnet på PUF-filen'@13@10'  .PUF er underforstået efternavn';
  
(* Nedenfor de fra GSX.PAS noedvendige procedurer og funktioner *)

  maxintin  = 80;	æ Maximum number of input integers å
  maxptsin  = 4;	æ Maximum number of input points å
  maxintout = 80;	æ Maximum number of output integers å
  maxptsout = 2;	æ Maximum number of output points å

TYPE
  coor      = RECORD
		x,y: integer;
	      END;
  stringin  = STRINGÆmaxintinÅ;
  stringout = STRINGÆmaxintoutÅ;

VAR
  contrl    : ARRAYÆ1..9Å OF integer;
  intin     : ARRAYÆ1..maxintinÅ OF integer;
  ptsin     : ARRAYÆ1..maxptsinÅ OF coor;
  intout    : ARRAYÆ1..maxintoutÅ OF integer;
  ptsout    : ARRAYÆ1..maxptsoutÅ OF coor;
  wsintout  : ARRAYÆ1..45Å OF integer;
  wsptsout  : ARRAYÆ1..6Å OF coor;
  mousestat,termv:integer;
  actual    : integer;

 æ$R-,K-å

 PROCEDURE gsx(VAR ctrl,inti,ptsi,into,ptso);
 TYPE
   gsxpb = RECORD
 	    ctrlp,intip,ptsip,intop,ptsop: ^integer;
 	  END;
   rpack = RECORD
 	    ax,bx,cx,dx,bp,si,di,ds,es,flags: integer;
 	  END;
 VAR
   pb: gsxpb;
   rp: rpack;
 BEGIN
   pb.ctrlp:=addr(ctrl);
   pb.intip:=addr(inti); pb.ptsip:=addr(ptsi);
   pb.intop:=addr(into); pb.ptsop:=addr(ptso);
   rp.cx:=$473; rp.dx:=ofs(pb); rp.ds:=seg(pb);
   swint(224,rp);
 END;

 PROCEDURE gsxc(func,npts,nint: integer);
 BEGIN
   contrlÆ1Å:=func; contrlÆ2Å:=npts; contrlÆ4Å:=nint;
   gsx(contrl,intin,ptsin,intout,ptsout);
 END;

 PROCEDURE gsxp(func,npts: integer; VAR ptsin);
 BEGIN
   contrlÆ1Å:=func; contrlÆ2Å:=npts; contrlÆ4Å:=0;
   gsx(contrl,intin,ptsin,intout,ptsout);
 END;

 PROCEDURE gsxi(func,value: integer);
 BEGIN
   intinÆ1Å:=value; gsxc(func,0,1); actual:=intoutÆ1Å;
 END;

 PROCEDURE gsxx(func,value: integer);
 BEGIN
   ptsinÆ1Å.x:=value; ptsinÆ1Å.y:=0;
   gsxc(func,1,0); actual:=ptsoutÆ1Å.x;
 END;

 PROCEDURE gsxy(func,value: integer);
 BEGIN
   ptsinÆ1Å.x:=0; ptsinÆ1Å.y:=value;
   gsxc(func,1,0); actual:=ptsoutÆ1Å.y;
 END;

 PROCEDURE openws(id: integer);
 CONST
   wsinti: ARRAYÆ2..10Å OF integer = (1,1,1,1,1,1,1,1,1);
 BEGIN
   intinÆ1Å:=id; move(wsinti,intinÆ2Å,18);
   contrlÆ1Å:=1; contrlÆ2Å:=0; contrlÆ4Å:=10;
   gsx(contrl,intin,ptsin,wsintout,wsptsout);
 END;

 PROCEDURE clearws;
 BEGIN
   gsxc(3,0,0);
 END;

 PROCEDURE polyline(npts: integer; VAR ptsin);
 BEGIN
   gsxp(6,npts,ptsin);
 END;

 PROCEDURE linetype(typ: integer);
 BEGIN
   gsxi(15,typ);
 END;

 PROCEDURE polyfill(npts: integer; VAR ptsin);
 BEGIN
   gsxp(9,npts,ptsin);
 END;

 PROCEDURE filltype(typ: integer);
 BEGIN
   gsxi(23,typ);
 END;

 PROCEDURE fillstyle(index: integer);
 BEGIN
   gsxi(24,index);
 END;

 PROCEDURE gtext(x,y: integer; s: stringin);
 VAR
   i: integer;
 BEGIN
   FOR i:=1 TO len(s) DO intinÆiÅ:=ord(sÆiÅ);
   ptsinÆ1Å.x:=x; ptsinÆ1Å.y:=y; gsxc(8,1,len(s));
 END;

 PROCEDURE charheight(height: integer;
   VAR charw,charh,cellw,cellh: integer);
 BEGIN
   gsxy(12,height);
   charw:=ptsoutÆ1Å.x; charh:=ptsoutÆ1Å.y;
   cellw:=ptsoutÆ2Å.x; cellh:=ptsoutÆ1Å.y;
 END;

 PROCEDURE charupvec(angle: integer);
 CONST
   f1800 = 0.001745329252; (* PI/1800 *)
 BEGIN
   intinÆ1Å:=angle;
   intinÆ2Å:=round(100.0*cos(angle*f1800));
   intinÆ3Å:=round(100.0*sin(angle*f1800));
   gsxc(13,0,3); actual:=intoutÆ1Å;
 END;

 PROCEDURE setcolor(index,red,green,blue: integer);
 BEGIN
   intinÆ1Å:=index; intinÆ2Å:=red;
   intinÆ3Å:=green; intinÆ4Å:=blue;
   gsxc(14,0,4);
 END;

 PROCEDURE linecolor(index: integer);
 BEGIN
   gsxi(17,index);
 END;

 PROCEDURE textcolor(index: integer);
 BEGIN
   gsxi(22,index);
 END;

 PROCEDURE fillcolor(index: integer);
 BEGIN
   gsxi(25,index);
 END;

 PROCEDURE escp(func,npts,nint: integer);
 BEGIN
   contrlÆ6Å:=func; gsxc(5,npts,nint);
 END;

 PROCEDURE escn(func: integer);
 BEGIN
   contrlÆ6Å:=func; gsxc(5,0,0);
 END;
  
(* Ovenfor de fra GSX.PAS noedvendige procedurer og funktioner *)

const
  aspekt=0.7;           æ Forhold mellem skaermens hoejde og bredde å

type
 str2=stringÆ2Å;str15=stringÆ15Å;str39=stringÆ39Å;
 bilrec=record
  kommando:byte;
  k:arrayÆ1..2Å of integer;
 end;
var
 regs:record
  ax,bx,cx,dx,bp,si,di,ds,es,flags:integer;
 end;
 tmin,tmax,xer,yer,xspring,yspring:integer;
 fpoints,step,nutype,ox,oy,nx,ny:integer;
 chw,chh,clw,clh:integer;
 tline:str39;
 corners:arrayÆ1..1000Å of coor;
 baselin:bilrec;
 billedfil:file of bilrec;
 ll,nu,count:byte;
 ch:char;
 contour,fillgem:boolean;
 xy:arrayÆ1..37Å of coor;
 iofejl,i,txwidth,txshadow,txcolour,fcolour,lcolour:integer;
 buetal:arrayÆ1..36,1..2Å of real;
 bilnavn:stringmax;

PROCEDURE PUFINIT; (* Initialiseringsrutine - buer til cirkeltegning *)
                   (* Div. systemafhængige konstanter *)
var
 bue:integer;
begin
 for bue:=1 to 36 do begin
  buetalÆbue,1Å:=aspekt*cos(10*bue*pi/180);
  buetalÆbue,2Å:=sin(10*bue*pi/180);
 end;
 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);
 returnfar;
end;
 
PROCEDURE DISPLAY; (* Rutine til fremvisning af billeder *)

 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/aspekt;yt:=y1;xt2:=x2/aspekt;yt2:=y2;
  if sqrt(sqr(xt-xt2)+sqr(yt-yt2))>maxint then
   radius:=maxint
  else
   radius:=round(sqrt(sqr(xt-xt2)+sqr(yt-yt2)));
  if x1+radius*aspekt<=maxint then
   x2:=round(x1+radius*aspekt)
  else
   x2:=maxint;
  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 (* SKYGGESKRIFT *)
  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)*2*yspring,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;
  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;
  
 PROCEDURE DRAWTO;
 begin
  nx:=baselin.kÆ1Å;ny:=baselin.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(baselin.kÆbnrÅ))+chr(lo(baselin.kÆbnrÅ));
 end;

begin (* DISPLAY *)
 getstringpar(1,bilnavn);
 assign(billedfil,bilnavn+'.PUF');
 (* Set file attribut UNLOCKED *)
 memÆseg(billedfil):ofs(billedfil)+17Å:=memÆseg(billedfil):ofs(billedfil)+17Å+128;
 (*$I-*)
 reset(billedfil);
 if iores=0 then begin
  SETUP;
  while not eof(billedfil) do begin
   step:=step+1;
   read(billedfil,baselin);
   nutype:=baselin.kommando;
   case nutype of
    0:begin (*PALETTE*)
      PALETTE(baselin.kÆ1Å,baselin.kÆ2Å);
     end;
    1:begin (*LINECOLOUR*)
      lcolour:=baselin.kÆ1Å;
      LINECOLOR(lcolour);
     end;
    2:begin (*FILLCOLOUR*)
      fcolour:=baselin.kÆ1Å; 
      FILLCOLOR(fcolour);
     end;
    3:begin (*TEGNCOLOUR*)
      txcolour:=baselin.kÆ1Å;
      TEXTCOLOR(txcolour);
     end;
    5:begin (*LINJETYPE*)
      LINETYPE(baselin.kÆ1Å);
     end;
    6:begin (*FILLTYPE*)
      FILLTYPE(baselin.kÆ1Å);
      FILLSTYLE(baselin.kÆ2Å);
     end;
    7:begin (*TEGNTYPE*)
      CHARUPVEC(hi(baselin.kÆ1Å)*50);
      CHARHEIGHT(lo(baselin.kÆ1Å)*yspring,chw,chh,clw,clh);
      txwidth:=hi(baselin.kÆ2Å);
      txshadow:=lo(baselin.kÆ2Å);
     end;
    20:begin (*STARTPOINT*)
      ox:=baselin.kÆ1Å;oy:=baselin.kÆ2Å;
      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:=(baselin.kÆ1Å=1);
      contour:=(fillgem and (baselin.kÆ2Å=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:begin (*BOXSLUT*)
      nx:=baselin.kÆ1Å;ny:=baselin.kÆ2Å;
      BOX(ox,oy,nx,ny);
      if fillgem then begin
       POLYFILL(5,xy);
       if contour then POLYLINE(5,xy);
       fillgem:=false;contour:=false;
      end;
      ox:=nx;oy:=ny;
     end;
    51:begin (*CIRKELSLUT*)
      nx:=baselin.kÆ1Å;ny:=baselin.kÆ2Å;
      RUND(ox,oy,nx,ny);
      if fillgem then begin
       POLYFILL(37,xy);
       if contour then POLYLINE(37,xy);
       fillgem:=false;contour:=false;
      end;
      ox:=nx;oy:=ny;
     end;
    60,70:begin (*SKRIVSTRENG*)
      ox:=baselin.kÆ1Å;oy:=baselin.kÆ2Å;
      step:=step+1;
      read(billedfil,baselin);
      ll:=baselin.kommando;
      tline:=DSCRAMB(1)+DSCRAMB(2);
      nu:=4;
      while (nu<ll) and not eof(billedfil) do begin
       step:=step+1;
       read(billedfil,baselin);
       tline:=tline+chr(baselin.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
     end;
    99:CLEARWS;
    100:begin (* PAUSE *)
     write(@7);
     if baselin.kÆ1Å=1 then begin
      gotoxy(0,23);write('PAUSE - TRYK EN TAST');
      read(kbd,ch);
      gotoxy(0,23);write('                    ');
     end else
      read(kbd,ch);
    end;
   end;
  end;
  regs.cx:=16;
  regs.ds:=seg(billedfil);
  regs.dx:=ofs(billedfil)+12;
  swint(224,regs); (* close(billedfil); *)
 end else begin
  gotoxy(0,23);
  write(@7'Kan ikke finde billede: '+bilnavn+'.PUF');
 end;
 (*$I+*)
 returnfar;
end;

BEGIN
  openfile('vispuf1.hov');
  skriv_versionsno;
  skriv_packtype;
  skriv_offset(ofs(dok_dis));
  skriv_offset(ofs(pufinit));
  skriv_offset(0);

  skriv_navn('pufinit');
  skriv_proc;
  skriv_offset(ofs(dok_init));
  skriv_offset(ofs(pufinit));
  skriv_byte(0);
    
  skriv_navn('display');
  skriv_proc;
  skriv_offset(ofs(dok_kald));
  skriv_offset(ofs(display));
  skriv_byte(1);
  skriv_navn('billednavn');
  skriv_typeogdim(valuepar+stringpar,0);
  
  skriv_byte(0);
  skriv_reserver;
  skriv_packtype;
  closefile;
  
END.«eof»