home *** CD-ROM | disk | FTP | other *** search
/ Turbo Toolbox / Turbo_Toolbox.iso / 1990 / 05 / praxis / snapshot.pas < prev    next >
Pascal/Delphi Source File  |  1990-02-14  |  7KB  |  222 lines
  1. (* ------------------------------------------------------ *)
  2. (*                   SNAPSHOT.PAS                         *)
  3. (*          (c) 1990 Gustl Huber & TOOLBOX                *)
  4. (* ------------------------------------------------------ *)
  5. {$R-,S-,I-,V-,B-,N-,D-}
  6. {$M 4096,0,655360}  { wenig Stack, Heap durch TSR begrenzt }
  7. PROGRAM Snapshot;
  8.  
  9. USES TSR, Crt, Dos, PCXTools;
  10.  
  11. CONST
  12.   SnapID     = 11;                   { Kennziffer          }
  13.   Version    = 'SNAPSHOT PLUS';
  14.   Hotkey     = $6800;                { Aktivierung: Alt-F1 }
  15.   HotkeyName = 'Alt-F1';
  16.   numpic     : WORD       = 1;
  17.   name                    = 'SNAP0000';
  18.   AttrScreen : BOOLEAN    = FALSE;
  19.  
  20. VAR
  21.   pfad       : STRING;
  22.   i          : INTEGER;
  23.  
  24.   FUNCTION HGCGrafik : BOOLEAN;
  25.   VAR
  26.     LP : RECORD
  27.            CASE INTEGER OF
  28.              0 : (LB, HB : BYTE);           { Pos. 2 Bytes }
  29.              1 : (LW     : INTEGER);        { Pos. 1 Word  }
  30.            END;
  31.   BEGIN
  32.     Port[$3BB] := 0;       { Reset des Light-Pen-Latch-Reg.}
  33.     WHILE(PORT[$3BA] AND $80 <> 0 ) DO {};         { Start }
  34.     WHILE(PORT[$3BA] AND $80 = 0 ) DO {};          { Ende  }
  35.     INLINE ($FA);           { cli, Interrupts unterdrücken }
  36.     WHILE(PORT[$3BA] AND $80 <> 0 ) DO {} ;
  37.     Port[$3B9]:=0;             { Light-Pen-Position merken }
  38.     INLINE ($FB);       { sti, Interrupts wieder zulassen  }
  39.     Port[$3B4] := $10; { Hi-Byte Light-Pen-Pos.   auslesen }
  40.     LP.HB := Port[$3B5];
  41.     Port[$3B4]:=$11;         { Lo-Byte Light-Pen-Pos.lesen }
  42.     LP.LB := Port[$3B5];
  43.     HGCGrafik := (LP.LW) > (45 * 87);
  44.   END;
  45.  
  46.   FUNCTION ExistFile(name : STRING) : BOOLEAN;
  47.   VAR
  48.     F : FILE;
  49.   BEGIN
  50.     Assign(F, name);
  51.     Reset(F);
  52.     ExistFile := (IOResult = 0);
  53.   END;
  54.  
  55.   PROCEDURE TXTScreen(Base : WORD);
  56.   VAR
  57.     S         : STRING[160];
  58.     R         : STRING[80];
  59.     I, J, Seg : WORD;
  60.     P         : POINTER;
  61.     F         : TEXT;
  62.   BEGIN
  63.     Assign(F, pfad + '.TXT');
  64.     Rewrite(F);
  65.     DOSError := IOResult;
  66.     IF DOSError <> 0 THEN Exit;
  67.     Seg := Base + $100 * PCXTools.ActivePage;
  68.     FOR I := 0 TO 24 DO BEGIN
  69.       P := Ptr(Seg, I*160);
  70.       S[0] := #160;
  71.       Move(P^, S[1], 160);
  72.       R := '';
  73.       J := 1;
  74.       WHILE J <= 160 DO BEGIN
  75.         R := R + S[J];
  76.         Inc(J, 2);
  77.       END;
  78.       WriteLn(F, R);
  79.       DOSError := IOResult;
  80.       IF DOSError <> 0 THEN BEGIN
  81.         Close(f);
  82.         DOSError := IOResult;
  83.         Exit;
  84.       END;
  85.     END;
  86.     Close(F);
  87.   END;
  88.  
  89.   PROCEDURE ATTScreen(Base : WORD);
  90.   VAR
  91.     P  : POINTER;
  92.     F  : FILE;
  93.   BEGIN
  94.     Assign(F, pfad+ '.ATT');
  95.     Rewrite(F, 1);
  96.     DOSError := IOResult;
  97.     IF DOSERROR <> 0 THEN Exit;
  98.     P := Ptr(WORD(Base + $100 * PCXTools.ActivePage), 0);
  99.     Blockwrite(F, P^, 4000);
  100.     DOSError := IOResult;
  101.     IF DOSERROR <> 0 THEN BEGIN
  102.       Close(f);
  103.       DOSError := IOResult;
  104.       Exit;
  105.     END;
  106.     Close(F);
  107.     IF IOResult <> 0 THEN;
  108.   END;
  109.  
  110. {$F+}
  111.   PROCEDURE GetPicture;
  112.   VAR
  113.     I      : INTEGER;
  114.     Regs   : Registers;
  115.     vmodus : WORD;
  116.     temp   : STRING[4];
  117.   BEGIN
  118.     Regs.ah  := $0F;
  119.     Intr($10, Regs);
  120.     vmodus  := Regs.al;
  121.     PCXTools.ActivePage := Regs.bh;
  122.     PCXTools.xmin       := 0;
  123.     PCXTools.YMin       := 0;
  124.     REPEAT
  125.       IF numpic > 9999 THEN Exit;
  126.       Str(numpic, temp);
  127.       Pfad := name;
  128.       Move(temp[1], pfad[9-Length(temp)], Length(temp));
  129.       Inc(numpic);
  130.     UNTIL (ExistFile(Pfad + '.PCX') = FALSE) AND
  131.           (ExistFile(Pfad +'.TXT') = FALSE) AND
  132.           (ExistFile(Pfad +'.ATT') = FALSE);
  133.     Write(^G);
  134.     CASE vmodus OF
  135.       $3, $83  :             { Text-Modi 40x25 und 80x25   }
  136.           IF AttrScreen THEN ATTScreen($B800)
  137.                         ELSE TXTScreen($B800);
  138.       $10, $90 :
  139.           BEGIN                                { EGA-Modi: }
  140.             PCXTools.Xmax := 639;
  141.             PCXTools.YMax := 349;
  142.             I := BGItoPCX(3, 1, Pfad + '.PCX');
  143.           END;
  144.       $0F, $8F :
  145.           BEGIN                                { EGA-Mono: }
  146.             PCXTools.Xmax := 639;
  147.             PCXTools.YMax := 349;
  148.             I := BGItoPCX(3, 3, Pfad + '.PCX');
  149.           END;
  150.       $0E, $8E :
  151.           BEGIN                  { CGA-Emulation durch EGA }
  152.             PCXTools.Xmax := 639;
  153.             PCXTools.YMax := 199;
  154.             I := BGItoPCX(3, 0, Pfad + '.PCX');
  155.           END;
  156.       $06, $86 :
  157.           BEGIN                                      { CGA }
  158.             PCXTools.xmax := 639;
  159.             PCXTools.YMax := 199;
  160.             I := BGItoPCX(1, 4, Pfad + '.PCX');
  161.           END;
  162.       $4, $5,
  163.       $84, $85 :
  164.           BEGIN                 { CGA-Modi mit 320 x 200   }
  165.             PCXTools.Xmax := 319;
  166.             PCXTools.YMax := 199;
  167.             I := BGItoPCX(1, 1, Pfad + '.PCX');
  168.           END;
  169.       $11, $91,
  170.       $12, $92 :
  171.           BEGIN                     { VGA-Grafik-Modi      }
  172.             PCXTools.Xmax := 639;
  173.             PCXTools.YMax := 479;
  174.             I := BGItoPCX(9, 2, Pfad + '.PCX');
  175.           END;
  176.        $07,$87 :
  177.           BEGIN
  178.             IF HGCGrafik THEN BEGIN         { Grafik-Modus }
  179.               PCXTools.Xmax := 719;
  180.               PCXTools.YMax := 347;
  181.               I := BGItoPCX(7, 0, pfad + '.PCX');
  182.             END ELSE BEGIN                   { Text-Modus: }
  183.               PCXTools.ActivePage := 0;
  184.               IF AttrScreen THEN ATTScreen($B000)
  185.                             ELSE TXTScreen($B000);
  186.             END;
  187.           END;
  188.     END;
  189.     Write(^G^G);
  190.   END;
  191. {$F-}
  192.  
  193. BEGIN
  194.   IF AlreadyLoaded(SnapID) THEN
  195.     WriteLn(Version, '  ist bereits geladen!',
  196.             ^M^J, 'Aktivieren Sie das Programm mit ',
  197.             HotKeyName, '.')
  198.   ELSE BEGIN
  199.     IF PopUpInstalled (@GetPicture, Hotkey, 24) THEN BEGIN
  200.       IF ParamCount > 0 THEN BEGIN
  201.         Pfad := ParamStr(1);
  202.         FOR i := 1 TO Length(Pfad) DO
  203.           Pfad[i] := UpCase(Pfad[i]);
  204.         IF (Pfad[1] = '/') AND (Pfad[2] = 'A') THEN
  205.           AttrScreen := TRUE;
  206.       END;
  207.       WriteLn(Version, ' installiert.',
  208.               ^M^J, 'Aktivieren Sie das Programm mit ',
  209.               HotKeyName, '.');
  210.       Write(^M^J,'Die Ablage der Textbildschirme erfolgt ');
  211.       CASE AttrScreen OF
  212.         FALSE : WriteLn('im reinen ASCII-Format');
  213.         TRUE  : WriteLn('inklusive der Attribute');
  214.       END;
  215.       MakeResident(SnapID);
  216.     END ELSE
  217.       WriteLn(Version, '  nicht installiert,', ^M^J,
  218.               'Fehler: Vermutlich zu wenig Hauptspeicher!');
  219.   END;
  220. END.
  221. (* ------------------------------------------------------ *)
  222. (*                Ende von SNAPSHOT.PAS                   *)