home *** CD-ROM | disk | FTP | other *** search
- PROGRAM ShowPCX (input , output);
-
- {$I "Include:Exec/Exec.i" }
- {$I "Include:Graphics/Graphics.I" }
- {$I "Include:Hardware/IntBits.I" }
- {$I "Include:libraries/Dosextens.I" }
- {$I "Include:Intuition/intuition.i" }
- {$I "Include:Intuition/Intuitionbase.i" }
- {$I "Include:Utils/Parameters.I" }
- {$I "Include:Utils/StringLib.i" }
- {$I "INCLUDE:Graphics/Blitter.i" }
- {$I "Include:Graphics/GfxBase.i" }
- {$I "Include:Graphics/View.i" }
- {$I "Include:graphics/Pens.i" }
- {$I "Include:Graphics/rastport.i" }
-
- (* ShowPCX V1.0 *)
-
- (* ein Anzeigeprogramm für Bilder im PCX-Format *)
-
- (* Autor : Andreas Neumann / 05.03.94 *)
-
- (* History : *)
-
- (* [1.00] - erste Version, basierend auf einer kurzen *)
- (* PCX-Dokumentation von Relax Productions im *)
- (* C-F. Läuft problemlos mit V2.8 mit Palette *)
- (* und V3.0-PCX-Bildern zusammen. *)
-
- (* ShowPCX © 1994 by Andreas Neumann *)
- (* ShowPCX ist freely distributable, es darf jedoch nur mit Erlaubnis *)
- (* des Autoren auf andere Disk-Serien übernommen werden. *)
-
- (* Bei Fragen : Andreas Neumann ; Auf dem Ruhbühl 151 ; *)
- (* 88090 Immenstaad ; Tel.: 07545 / 3483 *)
-
-
- CONST
- gfxname : String = ("graphics.library");
-
- CSI = CHR($9B);
-
- TYPE
-
-
- PCXHEAD = RECORD
- bytesperline,
- paletteinfo,
- horizres,
- vertres,
- winleft,
- wintop,
- winright,
- winbottom : SHORT;
- colormap : ARRAY [0..255] OF ARRAY [0..2] OF BYTE;
- planes,
- depth,
- fileid,
- bitsperpixel,
- version,
- encoding : BYTE;
- END;
-
-
- PCXHeadPtr = ^PCXHEAD;
-
-
- VAR
- PCXInfo : PCXHEAD;
-
- PNuScreen : NewScreen;
- PNuWindow : NewWindow;
-
-
- TYPE
-
- PCXErrors = (pcxNoErr,pcxOutofmem,pcxOpenScreenfailed,
- pcxOpenWindowfailed,pcxopenfailed,pcxWrongVersion,
- pcxReadWriteFailed);
-
- VAR
- PCXError : PCXErrors;
-
- CONST
- { ReadPCX-Flags }
-
- pfront = $1;
- pvisible = $2;
- pdontopen = $4;
- pf_window = $8;
-
- { PCXError-Strings }
-
- PCXErrorStrings : ARRAY [0..6] OF String =
- ("No Error","Out of Memory","OpenScreen failed",
- "OpenWindow failed","Open Failed","Wrong Iff",
- "ReadWrite failed");
-
-
-
- VAR
- dummyint,
- emptymouse : INTEGER;
- lname : STRING;
- ShowPCXScreen : ScreenPtr;
- awindow,
- ShowPCXWindow : WindowPtr;
- MyGfxBase : GfxBasePtr;
- MyIntuitionBase : IntuitionBasePtr;
- IMes : IntuiMessagePtr;
- WB : WBStartupPtr;
-
- {$A XREF _p%IntuitionBase }
-
-
- PROCEDURE OffDisplay;
-
- BEGIN
- {$A move.w #$100,$DFF096 }
- END;
-
-
- PROCEDURE OnDisplay;
-
- BEGIN
- {$A move.w #$8300,$DFF096 }
- END;
-
-
- PROCEDURE PointerOff (dummywin : WindowPtr);
-
- BEGIN
- WHILE VBeamPos>200 DO ;
- SetPointer (dummywin,Adr(emptymouse),0,0,0,0);
- END;
-
-
- PROCEDURE PointerOn (dummywin : WindowPtr);
-
- BEGIN
- ClearPointer (dummywin);
- END;
-
-
- PROCEDURE DoStyle (stil , ffarbe : Byte);
-
- BEGIN
- WRITE (CSI,stil,";3",ffarbe,"m");
- END;
-
- FUNCTION Hoch (basis : INTEGER; exp : INTEGER) : INTEGER;
-
- VAR h1 : INTEGER;
- h2 : INTEGER;
-
- BEGIN
- h1:=1;
- IF exp>0 THEN
- FOR h2:=1 TO exp DO
- h1:=h1*basis;
- Hoch:=h1;
- END;
-
-
- FUNCTION GetIBase : IntuitionBasePtr;
-
- BEGIN
- {$A move.l _p%IntuitionBase,d0
- }
- END;
-
- FUNCTION IsAGA (gb : GfxBasePtr) : BOOLEAN;
-
- BEGIN
- IF (gb^.ChipRevBits0 AND %100)=%100 THEN
- IsAGA:=TRUE
- ELSE
- IsAGA:=FALSE;
- END;
-
-
- PROCEDURE MySetRGB (vp : ViewPortPtr ; nr , r , g , b : BYTE ; gb : GfxBasePtr ; display : BOOLEAN);
-
- VAR sptr : ^Short;
-
- BEGIN
- sptr:=vp^.ColorMap^.ColorTable;
- sptr:=Address(Integer(sptr)+(nr*SIZEOF(SHORT)));
- sptr^:=((r shr 4)*$100)+((g shr 4)*$10)+(b shr 4);
- IF IsAGA (gb) THEN
- BEGIN
- sptr:=vp^.ColorMap^.LowColorBits;
- sptr:=Address(Integer(sptr)+(nr*SIZEOF(SHORT)));
- sptr^:=((r AND $F)*$100)+((g AND $F)*$10)+((b AND $F));
- END;
- IF display THEN
- BEGIN
- MakeVPort (gb^.ActiView,vp);
- MrgCop (gb^.ActiView);
- END;
- END;
-
-
- PROCEDURE BufSkip (VAR bufptr : Address ; bytes : INTEGER);
-
- BEGIN
- bufptr:=Address(Integer(bufptr)+bytes);
- END;
-
- FUNCTION GetByte (VAR workptr : ^Byte) : BYTE;
-
- VAR b : BYTE;
-
- BEGIN
- b:=workptr^;
- BufSkip (workptr,SIZEOF(BYTE));
- GetByte:=b;
- END;
-
- FUNCTION GetShort (VAR workptr : ^Short ; pclike : BOOLEAN) : SHORT;
-
- VAR
- s : SHORT;
- bptr1,
- bptr2 : ^Byte;
-
- BEGIN
- s:=workptr^;
- bptr1:=Address(workptr);
- BufSkip (workptr,SIZEOF(BYTE));
- bptr2:=Address(workptr);
- BufSkip (workptr,SIZEOF(BYTE));
- IF pclike THEN
- s:=(bptr2^*$100)+bptr1^;
- GetShort:=s;
- END;
-
-
- FUNCTION ReadPCX (name : String; Flags : INTEGER;
- VAR myScreen : ScreenPtr;
- VAR myWindow : WindowPtr) : BOOLEAN;
-
- VAR rp1,
- rp2,
- rp3,
- rp4,
- rp5,
- rp6,
- rp7,
- rp8,
- PCXLength,
- RPos,
- RLen : INTEGER;
- PCXWork,
- PCXBuffer : Address;
- PCXHandle : FileHandle;
- PCXLock : FileLock;
- PCXFInfo : FileInfoBlockPtr;
- pcxdone : BOOLEAN;
- rpbptr : ^Byte;
-
- PROCEDURE OpenPCXDisplay;
-
- VAR DummyRP : RastPortPtr;
- os : BYTE;
- i : INTEGER;
- BitMaps : ARRAY [0..7] OF PLANEPTR;
- BM : BitMapPtr;
-
- BEGIN
- WITH pNuScreen DO
- BEGIN
- width:=PCXInfo.winright-PCXInfo.winleft+1;
- height:=PCXInfo.winbottom-PCXInfo.wintop+1;
-
- leftEdge:=PCXInfo.winleft;
- topEdge:=PCXInfo.wintop;
-
- depth:=PCXInfo.depth;
-
- viewModes:=0;
- IF (width>400) AND ((depth<5) OR IsAga(GfxBase)) THEN ViewModes:=ViewModes OR HIRES;
- IF height>300 THEN ViewModes:=ViewModes OR LACE;
-
- detailPen:=0; blockPen:=0;
- stype:=CUSTOMSCREEN_f+SCREENQUIET_f;
- font:=NIL;
- defaultTitle:=NIL;
- gadgets:=NIL;
- customBitMap:=NIL;
- IF NOT ((pfront AND Flags)=pfront) THEN Inc(sType,SCREENBEHIND_f);
- END;
-
- IF (pdontopen AND Flags)=pdontopen THEN
- BEGIN
- pNuScreen.SType:=pNuScreen.SType OR CustomBitMap_F;
- WITH pNuScreen DO
- BEGIN
- CustomBitMap:=AllocMem(SizeOf(BitMap),MEMF_PUBLIC+MEMF_CLEAR);
- InitBitMap (CustomBitMap,depth,width,height);
- i:=0; {^}
- REPEAT
- customBitMap^.planes[i]:=AllocRaster(width,height);
- BitMaps[i]:=customBitMap^.planes[i];
- IF BitMaps[i]=NIL THEN
- PCXError:=pcxOutOfMem
- ELSE
- BltClear (BitMaps[i],RASSIZE(width,height),0);
- Inc(i);
- UNTIL (i=depth) OR (PCXError<>pcxNoErr);
- IF PCXError<>pcxNoErr THEN
- WHILE i>1 DO
- BEGIN
- Dec(i);
- FreeRaster(BitMaps[i],width,height);
- END;
- END;
- END
- ELSE
- BEGIN
- myScreen:=OpenScreen (Adr(pNuScreen));
- IF MyScreen=NIL THEN
- PCXError:=pcxOpenScreenfailed
- ELSE
- BEGIN
- DummyRP:=Adr(MyScreen^.SRastPort);
- BM:=DummyRP^.BitMap;
- FOR i:=0 TO pNuScreen.depth-1 DO
- BitMaps[i]:=BM^.planes[i];
- FOR i:=0 TO (Hoch(2,PCXInfo.depth)-1) DO
- MySetRGB (Adr(MyScreen^.SViewPort),i,PCXInfo.colormap[i,0],PCXInfo.colormap[i,1],PCXInfo.colormap[i,2],GfxBase,i=(Hoch(2,PCXInfo.depth)-1));
- END;
- END;
- WITH pNuWindow DO
- BEGIN
- leftEdge:=0; topEdge:=0;
- width:=PCXInfo.winright-PCXInfo.winleft+1;
- height:=PCXInfo.winbottom-PCXInfo.wintop+1;
- detailPen:=1;
- blockPen:=0;
- idcmpFlags:=MOUSEBUTTONS_f;
- flags:=BORDERLESS+NOCAREREFRESH+RMBTRAP+ACTIVATE;
- firstGadget:=NIL;
- checkMark:=NIL;
- title:=NIL;
- screen:=MyScreen;
- bitMap:=NIL;
- wtype:=CUSTOMSCREEN_F;
- END;
- IF ((pf_window AND FLAGS)=pf_window) AND (MyScreen<>NIL) THEN
- BEGIN
- MyWindow:=OpenWindow (Adr(pNuWindow));
- If Mywindow=NIL THEN
- begin
- CloseScreen (MyScreen);
- MyScreen:=NIL;
- PCXError:=pcxOpenWindowFailed;
- END;
- END;
- IF NOT ((pvisible AND Flags)=pvisible) THEN OffDisplay;
- END;
-
-
- PROCEDURE PaintPCX (x , y : SHORT ; c : BYTE);
-
- BEGIN
- SetAPen (Adr(myscreen^.SRastPort),c);
- WritePixel (Adr(myscreen^.SRastPort),x,y);
- END;
-
- BEGIN
- PCXError:=pcxnoErr;
- PCXHandle:=NIL;
- MyScreen:=NIL;
- MyWindow:=NIL;
- RPos:=0; RLen:=0;
- PCXBuffer:=NIL; PCXLength:=0;
- PCXHandle:=DOSOpen (name,MODE_OLDFILE);
- IF PCXHandle=NIL THEN
- BEGIN
- PCXError:=pcxReadWriteFailed;
- END
- ELSE
- BEGIN
- PCXLock:=Lock(name,MODE_OLDFILE);
- IF PCXLock=NIL THEN
- BEGIN
- DOSClose(PCXHandle);
- PCXError:=pcxReadWriteFailed;
- END
- ELSE
- BEGIN
- PCXFInfo:=AllocMem (Sizeof(FileInfoBlock),MEMF_CLEAR+MEMF_PUBLIC);
- IF Examine (PCXLock , PCXFInfo)=TRUE THEN
- BEGIN
- PCXLength:=PCXFInfo^.fib_Size;
- END;
- FreeMem (PCXFInfo,SizeOf(FileInfoBlock));
- UnLock (PCXLock);
- PCXBuffer:=AllocMem (PCXLength,MEMF_CLEAR+MEMF_PUBLIC);
- IF PCXBuffer=NIL THEN
- BEGIN
- DOSClose (PCXHandle);
- PCXError:=pcxReadWriteFailed;
- END
- ELSE
- BEGIN
- IF DOSRead (PCXHandle,PCXBuffer,PCXLength)<>PCXLength THEN
- BEGIN
- DOSClose (PCXHandle);
- FreeMem (PCXBuffer,PCXLength);
- PCXBuffer:=NIL;
- PCXError:=pcxReadWriteFailed;
- END
- ELSE
- BEGIN
- DOSClose (PCXHandle);
- PCXWork:=PCXBuffer;
- END;
- END;
- END;
- END;
- IF PCXBuffer<>NIL THEN
- BEGIN
- PCXInfo.fileID:=GetByte (PCXWork);
- PCXInfo.version:=GetByte (PCXWork);
- PCXInfo.encoding:=GetByte (PCXWork);
- PCXInfo.bitsperpixel:=GetByte (PCXWork);
- PCXInfo.winleft:=GetShort (PCXWork,TRUE);
- PCXInfo.wintop:=GetShort (PCXWork,TRUE);
- PCXInfo.winright:=GetShort (PCXWork,TRUE);
- PCXInfo.winbottom:=GetShort (PCXWork,TRUE);
- PCXInfo.horizres:=GetShort (PCXWork,TRUE);
- PCXInfo.vertres:=GetShort (PCXWork,TRUE);
- IF (PCXInfo.version=2) THEN
- BEGIN
- FOR rp1:=0 TO 15 DO
- FOR rp2:=0 TO 2 DO
- PCXInfo.colormap[rp1,rp2]:=GetByte(PCXWork);
- END
- ELSE
- BufSkip (PCXWork,16*3);
-
- BufSkip (PCXWork,1);
- PCXInfo.planes:=GetByte (PCXWork);
- IF PCXInfo.version<5 THEN
- PCXInfo.depth:=4
- ELSE
- PCXInfo.depth:=8;
- PCXInfo.bytesperline:=GetShort(PCXWork,TRUE);
- PCXInfo.paletteinfo:=GetShort(PCXWork,TRUE);
- IF (PCXInfo.version=5) THEN
- BEGIN
- PCXWork:=Address(Integer(PCXBuffer)+PCXLength-768);
- FOR rp1:=0 TO 255 DO
- FOR rp2:=0 TO 2 DO
- BEGIN
- PCXInfo.colormap[rp1,rp2]:=GetByte(PCXWork);
- END;
- END;
- PCXWork:=PCXBuffer;
- BufSkip (PCXWork,128); { der Header }
- IF WB=NIL THEN WRITELN ('Zeige......',name);
- OpenPCXDisplay;
- IF PCXError=pcxNoErr THEN
- BEGIN
- rp1:=0;
- WHILE (rp1<(PCXInfo.winbottom-PCXInfo.wintop+1)) AND (Integer(PCXWork)<(Integer(PCXBuffer)+PCXLength)) DO
- BEGIN
- FOR rp2:=1 TO PCXInfo.planes DO
- BEGIN
- rp3:=0;
- rp7:=0;
- pcxdone:=FALSE;
- WHILE pcxdone=FALSE DO
- BEGIN
- CASE PCXInfo.encoding OF
- 0 : BEGIN
- rp4:=GetByte(PCXWork);
- IF (PCXInfo.bitsperpixel=1) THEN
- BEGIN
- rpbptr:=Address(Integer(myscreen^.SBitMap.Planes[rp2-1])+(myscreen^.SBitMap.BytesPerRow*rp1)+rp3);
- rpbptr^:=rp4;
- Inc(rp3);
- END;
- IF (PCXInfo.bitsperpixel=8) THEN
- BEGIN
- PaintPCX (rp3,rp1,rp4);
- Inc(rp3);
- END;
- pcxdone:=(rp3>=PCXInfo.BytesPerLine);
- END;
- 1 : BEGIN
- rp4:=GetByte(PCXWork);
- IF (rp4 AND %11000000)=%11000000 THEN
- BEGIN
- {Count-Byte}
- rp5:=(rp4 AND %111111);
- rp4:=GetByte(PCXWork);
- IF (PCXInfo.bitsperpixel=1) THEN
- BEGIN
- WHILE rp5>0 DO
- BEGIN
- rpbptr:=Address(Integer(myscreen^.SBitMap.Planes[rp2-1])+(myscreen^.SBitMap.BytesPerRow*rp1)+rp3);
- rpbptr^:=rp4;
- Dec(rp5);
- Inc(rp3);
- END;
- END;
- IF (PCXInfo.bitsperpixel=8) THEN
- BEGIN
- SetApen (Adr(myscreen^.SRastPort),rp4);
- Move(Adr(myscreen^.SRastPort),rp3,rp1);
- IF rp5>0 THEN
- Draw(Adr(myscreen^.SRastPort),(rp3+rp5)-1,rp1);
- Inc (rp3,rp5);
- END;
- END
- ELSE
- BEGIN
- IF (PCXInfo.bitsperpixel=1) THEN
- BEGIN
- rpbptr:=Address(Integer(myscreen^.SBitMap.Planes[rp2-1])+(myscreen^.SBitMap.BytesPerRow*rp1)+rp3);
- rpbptr^:=rp4;
- Inc(rp3);
- END;
- IF (PCXInfo.bitsperpixel=8) THEN
- BEGIN
- PaintPCX (rp3,rp1,rp4);
- Inc(rp3);
- END;
- END;
- pcxdone:=(rp3>=PCXInfo.BytesPerLine);
- END;
- ELSE ;
- END;
- END;
- END;
- Inc(rp1);
- END;
- END;
- FreeMem (PCXBuffer,PCXLength);
- END;
- ReadPCX:=(PCXError=pcxNoErr);
- END;
-
-
- BEGIN
- emptymouse:=0;
- MyIntuitionBase:=GetIBase;
- awindow:=MyIntuitionBase^.ActiveWindow;
- lname:=AllocString(255);
- WB:=GetStartupMsg;
- IF WB<>NIL THEN
- BEGIN
- StrCpy (lname,WB^.sm_ArgList^[2].wa_Name);
- IF CurrentDir (WB^.sm_ArgList^[2].wa_Lock)=NIL THEN ;
- END
- ELSE
- BEGIN
- WRITELN;
- DoStyle (3,3);
- WRITE (' SHOWPCX V1.00 ');
- DoStyle (4,3);
- WRITE ('© 1994 by Andreas "Wurzelsepp <:-)" Neumann');
- DoStyle (0,3);
- WRITELN(' of NEUDELSOFT');
- DoStyle (0,1);
- WRITELN (' written in PCQ 1.2d - the pure Stuff');
- WRITELN;
- GetParam(1,lname);
- END;
- IF ((StrEq (lname,"?")=TRUE) OR (StrEq (lname,"-h")=TRUE)) AND (WB=NIL) THEN
- BEGIN
- WRITELN (' Erklärung :');
- WRITELN (' ShowPCX dient zum Ansehen von Bilder im PCX-Format. Dies ist das');
- WRITELN (' gängige Format auf MS-DOSen.');
- WRITELN (' Aufgerufen wird ShowPCX über das CLI.');
- WRITELN (' Dazu gibt man ein : "ShowPCX Bildname" [Return]');
- WRITELN (' "ShowPCX ?" oder "ShowPCX -h" zeigt diesen Hilfstext.');
- WRITELN;
- END
- ELSE
- BEGIN
- GfxBase :=OpenLibrary(gfxname, 0);
- MyGfxBase := GfxBase;
-
- PointerOff (awindow);
-
- IF ReadPCX (lname,pf_window+pvisible,ShowPCXScreen,ShowPCXWindow) THEN
- BEGIN
-
- ScreenToFront (ShowPCXScreen);
-
- PointerOff (ShowPCXWindow);
- ActivateWindow (ShowPCXWindow);
-
- REPEAT
-
- dummyint:=0;
- WaitPort (ShowPCXWindow^.UserPort);
- IMes:=Address(GetMsg(ShowPCXWindow^.UserPort));
- IF IMes<>NIL THEN
- BEGIN
- dummyint:=IMes^.Code;
- ReplyMsg (Address(IMes));
- END;
- UNTIL dummyint=SELECTUP;
-
- PointerOn (ShowPCXWindow);
- ScreenToBack (ShowPCXScreen);
- CloseWindow (ShowPCXWindow);
- CloseScreen (ShowPCXScreen);
- END
- ELSE
- BEGIN
- DisplayBeep(NIL);
- IF WB=NIL THEN WRITELN (PCXErrorStrings[Integer(PCXError)]);
- END;
- CloseLibrary (GfxBase);
- END;
- IF awindow<>NIL THEN BEGIN ActivateWindow (awindow); PointerOn (awindow); END;
- FreeString (lname);
- END.
-
-
-
-
-