[Back to COMM SWAG index] [Back to Main SWAG index] [Original]
{ RIPSEE.PAS version 1.0 views a RIP 1.54 in EGA
Public domain by Jason Dyer, use is free, but it would be nice if you gave
me credit. Netmail at jason.dyer@solitud.fidonet.org on Internet or 1:300/23
on Fidonet. If anyone can tell me the REAL way to scroll the graphic part of
the screen please tell me.
This program assumes you have TP/BP 7.0+ because of the new fonts it adds.
If you are using anything less you will have to add the new fonts manually.
Also, the icon format is different...the "trash byte" isn't used in 6.0.
A few things are missing, like mouse buttons and the text window...expect
them in a later version. }
PROGRAM RipSee;
USES Crt, Dos, Graph;
CONST Place : ARRAY [1..5] OF LONGINT = (1, 36, 1296, 46656, 1679616);
Seq = ('0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ');
VAR ErrorCode : INTEGER;
GrDriver, GrMode : INTEGER;
f : TEXT;
SSS : STRING;
ccol : INTEGER;
Ch : CHAR;
Clipboard : POINTER;
LLL : INTEGER;
command : STRING;
RipLine, bslash : BOOLEAN;
FUNCTION FileExists (zzz : STRING) : BOOLEAN;
VAR DoCheck : SearchRec;
BEGIN
FINDFIRST (zzz, AnyFile, DoCheck);
IF DosError = 0 THEN FileExists := TRUE ELSE FileExists := FALSE;
END;
PROCEDURE WriteString (SSS : STRING; CP : INTEGER);
VAR Prloop : INTEGER;
Regs : REGISTERS;
BEGIN
regs.ah := $0E;
regs.bh := 0;
regs.bl := cp;
FOR PrLoop := 1 TO LENGTH (SSS) DO BEGIN
Regs.Al := ORD (SSS [PrLoop]);
INTR ($10, Regs);
END;
END;
FUNCTION Convert (SS : STRING) : LONGINT;
VAR PrLoop, Counter : INTEGER;
CA, Tag : LONGINT;
BEGIN
IF LENGTH (ss) = 1 THEN ss := '0' + ss;
Counter := 0; CA := 0;
FOR PrLoop := LENGTH (SS) DOWNTO 1 DO BEGIN
Counter := Counter + 1;
Tag := POS (SS [PrLoop], Seq) - 1;
CA := CA + (Tag * Place [Counter]);
END;
Convert := CA;
END;
PROCEDURE DrawBezierCurve (px1, py1, px2, py2, px3, py3, px4, py4, count : INTEGER);
FUNCTION pow (x : REAL; y : WORD) : REAL;
VAR
nt : WORD;
result : REAL;
BEGIN
result := 1;
FOR nt := 1 TO y DO
result := result * x;
pow := result;
END;
PROCEDURE Bezier (t : REAL; VAR x, y : INTEGER);
BEGIN
x := TRUNC (pow (1 - t, 3) * px1 + 3 * t * pow (1 - t, 2) * px2 +
3 * t * t * (1 - t) * px3 + pow (t, 3) * px4);
y := TRUNC (pow (1 - t, 3) * py1 + 3 * t * pow (1 - t, 2) * py2 +
3 * t * t * (1 - t) * py3 + pow (t, 3) * py4);
END;
VAR
resolution, t : REAL;
xc, yc : INTEGER;
BEGIN
IF count = 0 THEN EXIT;
resolution := 1 / count;
MOVETO (px1, py1);
t := 0;
WHILE t < 1 DO BEGIN
Bezier (t, xc, yc);
LINETO (xc, yc);
t := t + resolution;
END;
LINETO (px4, py4);
END;
PROCEDURE Scrollgraph (x1, y1, x2, y2, dest : INTEGER);
VAR PP : POINTER;
BEGIN
IF x1 MOD 8 <> 0 THEN x1 := x1 DIV 8;
IF x2 MOD 8 <> 0 THEN x2 := (x2 + 8) DIV 8;
GETMEM (pp, IMAGESIZE (x1, y1, x2, y2) );
GETIMAGE (x1, y1, x2, y2, pp^);
PUTIMAGE (x1, dest, pp^, 0);
DISPOSE (pp);
END;
PROCEDURE ResetWindows;
BEGIN
SETVIEWPORT (0, 0, GETMAXX, GETMAXY, ClipOn);
CLEARDEVICE; IF clipboard <> NIL THEN DISPOSE (clipboard);
clipboard := NIL;
END;
PROCEDURE usersetf;
VAR ii, jj : INTEGER;
zz : FillPatternType;
BEGIN
jj := 0;
FOR ii := 1 TO 8 DO BEGIN
jj := jj + 2;
zz [ii] := Convert (COPY (command, jj, 2) );
END;
SETFILLPATTERN (zz, Convert (COPY (command, 18, 2) ) );
END;
PROCEDURE DPoly (fillit, ifpoly : BOOLEAN; np : INTEGER);
VAR ii, zz, yy : INTEGER;
poly : ARRAY [1..200] OF PointType;
BEGIN
ii := 4;
FOR zz := 1 TO np DO BEGIN
poly [zz].x := Convert (COPY (command, ii, 2) );
poly [zz].y := Convert (COPY (command, ii + 2, 2) );
ii := ii + 4;
END; IF ifpoly THEN BEGIN
poly [np + 1] := poly [1];
IF NOT fillit THEN DRAWPOLY (np + 1, poly) ELSE FILLPOLY (np + 1, poly);
END ELSE IF NOT fillit THEN DRAWPOLY (np, poly) ELSE FILLPOLY (np, poly);
END;
PROCEDURE toclip (x1, y1, x2, y2 : INTEGER);
BEGIN
IF clipboard <> NIL THEN DISPOSE (clipboard);
GETMEM (clipboard, IMAGESIZE (x1, y1, x2, y2) );
GETIMAGE (x1, y1, x2, y2, ClipBoard^);
END;
PROCEDURE LoadIcon (x, y, mode, cboard : INTEGER; fname : STRING);
VAR fi : FILE;
P : POINTER;
Z : LONGINT;
tt : TextSettingsType;
cc : WORD;
BEGIN
IF NOT fileexists (fname) THEN BEGIN
IF cboard = 1 THEN clipboard := NIL;
GETTEXTSETTINGS (tt); cc := GETCOLOR;
SETTEXTSTYLE (DefaultFont, HorizDir, 1); SETCOLOR (15);
OUTTEXTXY (x, y, Fname);
OUTTEXTXY (x, y + TEXTHEIGHT (Fname), 'not found');
SETCOLOR (cc); SETTEXTSTYLE (tt.font, tt.direction, tt.charsize);
END ELSE BEGIN
ASSIGN (fi, fname); NEW (P);
RESET (fi);
z := FILESIZE (fi);
GETMEM (P, FILESIZE (fi) );
BLOCKREAD (fi, P^, FILESIZE (fi) );
CLOSE (fi);
IF cboard = 1 THEN clipboard := p;
PUTIMAGE (x, y, p^, mode);
DISPOSE (p);
END;
END;
PROCEDURE allpalette;
VAR Pal : PaletteType;
ii, jj : INTEGER;
BEGIN
Pal.Size := 16;
jj := 0;
FOR ii := 1 TO 16 DO BEGIN
jj := jj + 2;
Pal.Colors [ii - 1] := Convert (COPY (command, jj, 2) );
END;
SETALLPALETTE (Pal);
END;
PROCEDURE ParseCommand (command : STRING);
BEGIN
IF command = '*' THEN resetwindows;
IF command [1] = 'W' THEN SetWriteMode (Convert (COPY (command, 2, 2) ) );
IF command [1] = 'S' THEN SETFILLSTYLE (Convert (COPY (command, 2, 2) ),
Convert (COPY (command, 4, 2) ) );
IF command [1] = 'E' THEN CLEARVIEWPORT;
IF command [1] = 'v' THEN SETVIEWPORT (Convert (COPY (command, 2, 2) ),
Convert (COPY (command, 4, 2) ),
Convert (COPY (command, 6, 2) ),
Convert (COPY (command, 8, 2) ), ClipOn);
IF command [1] = 'c' THEN IF LENGTH (command) = 2 THEN
BEGIN ccol := (POS (command [2], Seq) - 1); SETCOLOR (ccol); END
ELSE BEGIN ccol := (Convert (COPY (command, 2, 2) ) ); SETCOLOR (ccol); END;
IF command [1] = 'Y' THEN SETTEXTSTYLE (Convert (COPY (command, 2, 2) ),
Convert (COPY (command, 4, 2) ),
Convert (COPY (command, 6, 2) ) );
IF command [1] = 's' THEN usersetf;
IF command [1] = 'Q' THEN allpalette;
IF command [1] = '@' THEN OUTTEXTXY (Convert (COPY (command, 2, 2) ),
Convert (COPY (command, 4, 2) ),
COPY (command, 6, LENGTH (command) - 5) );
IF command [1] = 'F' THEN FLOODFILL (Convert (COPY (command, 2, 2) ),
Convert (COPY (command, 4, 2) ),
Convert (COPY (command, 6, 2) ) );
IF command [1] = 'C' THEN CIRCLE (Convert (COPY (command, 2, 2) ),
Convert (COPY (command, 4, 2) ),
Convert (COPY (command, 6, 2) ) );
IF command [1] = 'B' THEN BAR (Convert (COPY (command, 2, 2) ),
Convert (COPY (command, 4, 2) ),
Convert (COPY (command, 6, 2) ),
Convert (COPY (command, 8, 2) ) );
IF command [1] = 'A' THEN ARC (Convert (COPY (command, 2, 2) ),
Convert (COPY (command, 4, 2) ),
Convert (COPY (command, 6, 2) ),
Convert (COPY (command, 8, 2) ),
Convert (COPY (command, 10, 2) ) );
IF command [1] = 'I' THEN PIESLICE (Convert (COPY (command, 2, 2) ),
Convert (COPY (command, 4, 2) ),
Convert (COPY (command, 6, 2) ),
Convert (COPY (command, 8, 2) ),
Convert (COPY (command, 10, 2) ) );
IF command [1] = 'i' THEN Sector (Convert (COPY (command, 2, 2) ),
Convert (COPY (command, 4, 2) ),
Convert (COPY (command, 6, 2) ),
Convert (COPY (command, 8, 2) ),
Convert (COPY (command, 10, 2) ),
Convert (COPY (command, 12, 2) ) );
IF command [1] = 'L' THEN LINE (Convert (COPY (command, 2, 2) ),
Convert (COPY (command, 4, 2) ),
Convert (COPY (command, 6, 2) ),
Convert (COPY (command, 8, 2) ) );
IF command [1] = 'R' THEN RECTANGLE (Convert (COPY (command, 2, 2) ),
Convert (COPY (command, 4, 2) ),
Convert (COPY (command, 6, 2) ),
Convert (COPY (command, 8, 2) ) );
IF command [1] = 'o' THEN FillEllipse (Convert (COPY (command, 2, 2) ),
Convert (COPY (command, 4, 2) ),
Convert (COPY (command, 6, 2) ),
Convert (COPY (command, 8, 2) ) );
IF (command [1] = 'O') OR (command [1] = 'V') THEN
ELLIPSE (Convert (COPY (command, 2, 2) ),
Convert (COPY (command, 4, 2) ),
Convert (COPY (command, 6, 2) ),
Convert (COPY (command, 8, 2) ),
Convert (COPY (command, 10, 2) ),
Convert (COPY (command, 12, 2) ) );
IF command [1] = 'P' THEN Dpoly (FALSE, TRUE, Convert (COPY (command, 2, 2) ) );
IF command [1] = 'p' THEN Dpoly (TRUE, TRUE, Convert (COPY (command, 2, 2) ) );
IF command [1] = 'X' THEN PUTPIXEL (Convert (COPY (command, 2, 2) ),
Convert (COPY (command, 4, 2) ), ccol);
IF command [1] = 'a' THEN SETPALETTE (Convert (COPY (command, 2, 2) ),
Convert (COPY (command, 4, 2) ) );
IF command [1] = '=' THEN SETLINESTYLE (Convert (COPY (command, 2, 2) ),
Convert (COPY (command, 4, 4) ),
Convert (COPY (command, 8, 2) ) );
IF command [1] = 'l' THEN Dpoly (FALSE, FALSE, Convert (COPY (command, 2, 2) ) );
IF command [1] = 'Z' THEN DrawBezierCurve (Convert (COPY (command, 2, 2) ),
Convert (COPY (command, 4, 2) ),
Convert (COPY (command, 6, 2) ),
Convert (COPY (command, 8, 2) ),
Convert (COPY (command, 10, 2) ),
Convert (COPY (command, 12, 2) ),
Convert (COPY (command, 14, 2) ),
Convert (COPY (command, 16, 2) ),
Convert (COPY (command, 18, 2) ) );
IF command [1] = '1' THEN BEGIN {level one commands}
IF command [2] = 'C' THEN Toclip (Convert (COPY (command, 3, 2) ),
Convert (COPY (command, 5, 2) ),
Convert (COPY (command, 7, 2) ),
Convert (COPY (command, 9, 2) ) );
IF (command [2] = 'P') AND (Clipboard <> NIL)
THEN PUTIMAGE (Convert (COPY (command, 3, 2) ),
Convert (COPY (command, 5, 2) ),
Clipboard^,
Convert (COPY (command, 7, 2) ) );
IF command [2] = 'I' THEN LoadIcon (Convert (COPY (command, 3, 2) ),
Convert (COPY (command, 5, 2) ),
Convert (COPY (command, 7, 2) ),
Convert (COPY (command, 9, 1) ),
COPY (command, 12, LENGTH (command) - 11) );
IF command [2] = 'G' THEN Scrollgraph (Convert (COPY (command, 3, 2) ),
Convert (COPY (command, 5, 2) ),
Convert (COPY (command, 7, 2) ),
Convert (COPY (command, 9, 2) ),
Convert (COPY (command, 13, 2) ) );
END;
END;
PROCEDURE Init;
VAR FName : STRING;
BEGIN
clipboard := NIL;
DETECTGRAPH (GrDriver, Grmode);
IF GrDriver < 3 THEN BEGIN
WRITELN ('EGA not detected!');
HALT (1);
END; GrMode := vgahi; Grdriver := vga;
INITGRAPH (GrDriver, GrMode, '\turbo\tp'); { The address of your BGI files }
ErrorCode := GRAPHRESULT;
IF ErrorCode <> grOK THEN
BEGIN
WRITELN ('Graphics error:');
WRITELN (GraphErrorMsg (ErrorCode) );
WRITELN ('Program aborted...');
HALT (1);
END;
Fname := PARAMSTR (1);
IF POS ('.', Fname) = 0 THEN Fname := Fname + '.RIP';
IF (NOT FileExists (Fname) ) OR (Fname = '.RIP') THEN BEGIN
WRITELN ('File not found!');
HALT (1);
END;
CLEARDEVICE; LLL := 0; command := ''; bslash := FALSE;
ASSIGN (f, Fname); ripline := FALSE; RESET (f);
END;
BEGIN
Init;
REPEAT
READ (f, Ch);
IF (ORD (ch) = 13) OR (ORD (ch) = 10) THEN BEGIN
IF bslash = TRUE THEN BEGIN READ (f, ch); bslash := FALSE;
END ELSE BEGIN
LLL := 0; READ (f, ch);
IF ripline = TRUE THEN ripline := FALSE ELSE
WriteString (ch, 15);
END;
END ELSE BEGIN
LLL := LLL + 1;
IF (LLL = 1) AND (Ch = '!') THEN ripline := TRUE ELSE BEGIN
IF ripline THEN BEGIN
CASE ch OF
'|' : BEGIN
IF bslash THEN BEGIN command := command + ch; bslash := FALSE; END ELSE
BEGIN
IF command <> '' THEN ParseCommand (command);
command := '';
END;
END;
'\' : BEGIN
IF bslash THEN BEGIN command := command + ch; bslash := FALSE; END ELSE
bslash := TRUE;
END;
ELSE command := command + ch;
END;
END ELSE BEGIN
WriteString (ch, 15);
END;
END;
END;
UNTIL EOF (f);
CLOSE (f);
IF command <> '' THEN ParseCommand (command);
Ch := READKEY;
CLOSEGRAPH;
END.
[Back to COMM SWAG index] [Back to Main SWAG index] [Original]