[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]