home *** CD-ROM | disk | FTP | other *** search
/ Power-Programmierung / CD1.mdf / pascal / library / dos / grafik / vgakit / lbm / snaplbm.pas < prev   
Encoding:
Pascal/Delphi Source File  |  1991-09-17  |  6.8 KB  |  321 lines
  1.  
  2. PROGRAM SNAPLBM;
  3. {
  4.   RESIDENTES PROGRAMM ZUM ERZEUGEN VON 'SNAPSHOTS' IN DEN 256- FARBEN-
  5.   VIDEO- MODI DES TSENG ET 4000- CHIPS
  6.  
  7.   Paul Schubert, Rottweiler Str. 8, D6000 Frankfurt /M 1, 069 / 231145
  8.  
  9.   DIE UNIT TSR WURDE IN DER ZEITSCHRIFT TOOLBOX VERÖFFENTLICHT
  10. }
  11. {$M 4096,0,655360}
  12. {$R-}
  13. {$S-}
  14. {$V-}
  15. {$I-}
  16.  
  17. USES  TSR,DOS,CRT,TPINLINE;
  18.  
  19.  
  20. {$DEFINE BEEPS}
  21.  
  22.  
  23. CONST SnapID     = 11;                   { Kennziffer          }
  24.       Version    = 'SNAPLBM';
  25.       Hotkey     = $6800;                { Aktivierung: Alt-F1 }
  26.       HotkeyName = 'Alt-F1';
  27.  
  28. CONST LINLEN       = 1024;
  29.       SEGP  : WORD = $3CD; { PORTADRESSE FÜR VIDEO- RAM- SEGMENT }
  30.  
  31.       FN : STRING[64] = 'SNAP0001.LBM';
  32.  
  33.  
  34. TYPE  CMAPTYP  = ARRAY[0..255,0..2] OF BYTE;
  35.       PALTYP   = ARRAY[0..15,0..2] OF BYTE;
  36.  
  37.       COLORVALUE = RECORD R,G,B : BYTE END;
  38.       VGAPALETTETYPE = ARRAY[0..255] OF COLORVALUE;
  39.  
  40.  
  41. TYPE  HDRTYP = RECORD
  42.         WID,HIG   : WORD;
  43.         FILL0     : ARRAY[1..4] OF BYTE;
  44.         BPP       : BYTE;
  45.         AMI1      : BYTE;
  46.         COMPR     : BYTE;
  47.         FILL      : BYTE;
  48.         FGCOL     : BYTE;
  49.         BKCOL     : BYTE;
  50.         XRAT,YRAT : BYTE;
  51.         SCWID     : WORD;
  52.         SCHIG     : WORD;
  53.       END;
  54.  
  55.  
  56. VAR   I,J                  : INTEGER;
  57.       S                    : STRING;
  58.       XWID,YWID            : WORD;
  59.       VMOD                 : BYTE ABSOLUTE $40:$49;
  60.       F                    : FILE;
  61.       N                    : ARRAY[1..4] OF CHAR;
  62.       L                    : LONGINT;
  63.  
  64.       CMAP                 : CMAPTYP;
  65.       PAL                  : VGAPALETTETYPE ABSOLUTE CMAP;
  66.       HDR                  : HDRTYP;
  67.       LINBUF               : ARRAY[0..LINLEN] OF BYTE;
  68.  
  69.       FIXMOD               : BYTE;
  70.       INTVECS              : ARRAY[0..255] OF POINTER ABSOLUTE 0:0;
  71.  
  72.  
  73. FUNCTION LSWAP(L:LONGINT):LONGINT;
  74. VAR   B   : ARRAY[0..3] OF BYTE;
  75.       B1  : BYTE;
  76.       L1  : LONGINT ABSOLUTE B;
  77. BEGIN
  78.   MOVE(L,B,4);
  79.   B1 := B[0];
  80.   B[0] := B[3]; B[3] := B1;
  81.   B1 := B[2];
  82.   B[2] := B[1];
  83.   B[1] := B1;
  84.   LSWAP := L1;
  85. END; { LSWAP }
  86.  
  87.  
  88. PROCEDURE GETVGAPALETTE;
  89. VAR   I,J  : BYTE;
  90.       R    : REGISTERS;
  91. BEGIN
  92.   R.AX := $1017;
  93.   R.BX := 0;
  94.   R.CX := 256;
  95.   R.ES := Seg(PAL);
  96.   R.DX := Ofs(PAL);
  97.   INTR($10,R);
  98.   FOR I := 0 TO 255 DO BEGIN
  99.     FOR J := 0 TO 2 DO BEGIN
  100.       IF CMAP[I,J] <> 0 THEN CMAP[I,J] := (CMAP[I,J] SHL 2) OR 3;
  101.     END; { NEXT J }
  102.   END; { NEXT I }
  103. END; { GETVGAPALETTE }
  104.  
  105.  
  106. PROCEDURE WRITEHDR;
  107. BEGIN
  108.   N := 'FORM';
  109.   BLOCKWRITE(F,N,4);
  110.   L := LONGINT(LONGINT(XWID) * LONGINT(YWID) + LONGINT(48) + LONGINT($300));
  111.   L := LSWAP(L);
  112.   BLOCKWRITE(F,L,4);
  113.   N := 'PBM ';
  114.   BLOCKWRITE(F,N,4);
  115.   N := 'BMHD';
  116.   BLOCKWRITE(F,N,4);
  117.   L := LSWAP(20);
  118.   BLOCKWRITE(F,L,4);
  119.   FILLCHAR(HDR,SIZEOF(HDR),0);
  120.   WITH HDR DO BEGIN
  121.     WID   := SWAP(XWID);
  122.     HIG   := SWAP(YWID);
  123.     BPP   := 8;
  124.     COMPR := 0;
  125.     SCWID := SWAP(XWID);
  126.     SCHIG := SWAP(YWID);
  127.   END; { WITH HDR }
  128.   BLOCKWRITE(F,HDR,SIZEOF(HDR));
  129. END; { WRITEHDR }
  130.  
  131.  
  132. FUNCTION GETVIDEO:BOOLEAN;
  133. VAR   VM  : BYTE;
  134. BEGIN
  135.   GETVIDEO := FALSE;
  136.   IF FIXMOD <> 0 THEN VM := FIXMOD
  137.                  ELSE VM := VMOD;
  138.   IF VM = $13 THEN BEGIN
  139.     XWID := 320;
  140.     YWID := 200;
  141.     GETVIDEO := TRUE;
  142.     EXIT;
  143.   END;
  144.   IF VM = $2D THEN BEGIN
  145.     XWID := 640;
  146.     YWID := 350;
  147.     GETVIDEO := TRUE;
  148.     EXIT;
  149.   END;
  150.   IF VM = $2F THEN BEGIN
  151.     XWID := 640;
  152.     YWID := 400;
  153.     GETVIDEO := TRUE;
  154.     EXIT;
  155.   END;
  156.   IF VM = $2E THEN BEGIN
  157.     XWID := 640;
  158.     YWID := 480;
  159.     GETVIDEO := TRUE;
  160.     EXIT;
  161.   END;
  162.   IF VM = $30 THEN BEGIN
  163.     XWID := 800;
  164.     YWID := 600;
  165.     GETVIDEO := TRUE;
  166.     EXIT;
  167.   END;
  168.   IF VM = $38 THEN BEGIN
  169.     XWID := 1024;
  170.     YWID := 768;
  171.     GETVIDEO := TRUE;
  172.     EXIT;
  173.   END;
  174. END; { GETVIDEO }
  175.  
  176.  
  177. { SEGMENT DER VGA- KARTE FÜR LESEN UND SCHREIBEN SETZEN }
  178. PROCEDURE SETSEG(NR:BYTE);
  179. BEGIN
  180. (* ET 4000 *)
  181.   PORT[SEGP] := (NR AND $0F) SHL 4 + (NR AND $0F);
  182. (* ET 3000
  183.   PORT[SEGP] := ((NR AND $07) SHL 3 + (NR AND $07)) OR $20;
  184. *)
  185. END; { SETSEG }
  186.  
  187.  
  188. PROCEDURE INCNAME;
  189. VAR   I  : BYTE;
  190. BEGIN
  191.   I := 8;
  192.   REPEAT
  193.     INC(FN[I]);
  194.     IF FN[I] > '9' THEN BEGIN
  195.       FN[I] := '0';
  196.       DEC(I);
  197.     END ELSE EXIT;
  198.   UNTIL I < 5;
  199. END; { INCNAME }
  200.  
  201.  
  202. {$F+}
  203. PROCEDURE WRITELBM;
  204. VAR   SEGM,B1,B2  : BYTE;
  205.       X,Y         : WORD;
  206. LABEL LOOP;
  207. BEGIN
  208.   IF GETVIDEO THEN BEGIN
  209. LOOP:
  210.     ASSIGN(F,FN);
  211.     RESET(F);
  212.     IF IORESULT = 0 THEN BEGIN
  213.       INCNAME;
  214.       GOTO LOOP;
  215.     END ELSE BEGIN
  216.       CLOSE(F);
  217.     END;
  218. {$IFDEF BEEPS}
  219.     SOUND(1000);
  220.     DELAY(50);
  221.     NOSOUND;
  222. {$ENDIF}
  223.  
  224.     SEGM := PORT[SEGP];
  225.     GETVGAPALETTE;
  226.     ASSIGN(F,FN);
  227.     REWRITE(F,1);
  228.     WRITEHDR;
  229.  
  230.     N := 'CMAP';
  231.     BLOCKWRITE(F,N,4);
  232.     L := LSWAP(LONGINT($300));
  233.     BLOCKWRITE(F,L,4);
  234.     BLOCKWRITE(F,PAL,SIZEOF(PAL));
  235.     N := 'BODY';
  236.     BLOCKWRITE(F,N,4);
  237.     L := LSWAP(LONGINT(LONGINT(XWID) * LONGINT(YWID)));
  238.     BLOCKWRITE(F,L,4);
  239.  
  240.     B1 := 0;
  241.     SETSEG(0);
  242.     L := LONGINT(LONGINT(XWID) * LONGINT(YWID));
  243.     WHILE L >= 65536 DO BEGIN
  244.       BLOCKWRITE(F,MEM[$A000:0],65535);
  245.       BLOCKWRITE(F,MEM[$A000:$FFFF],1);
  246.       INC(B1);
  247.       SETSEG(B1);
  248.       DEC(L,65536);
  249.     END;
  250.     IF L > 0 THEN BLOCKWRITE(F,MEM[$A000:0],L);
  251.  
  252.     CLOSE(F);
  253.  
  254.     PORT[SEGP] := SEGM;
  255.  
  256.     INCNAME;
  257.  
  258. {$IFDEF BEEPS}
  259.     SOUND(2000);
  260.     DELAY(50);
  261.     SOUND(500);
  262.     DELAY(50);
  263.     SOUND(1000);
  264.     DELAY(50);
  265.     NOSOUND;
  266. {$ENDIF}
  267.   END ELSE BEGIN
  268. {$IFDEF BEEPS}
  269.     SOUND(300);
  270.     DELAY(200);
  271.     NOSOUND;
  272. {$ENDIF}
  273.   END;
  274. END; { WRITELBM }
  275. {$F-}
  276.  
  277.  
  278. PROCEDURE WASKANNICH;
  279. BEGIN
  280.   WRITELN;
  281.   WRITELN(' Abspeichern von Bildschirminhalten in den 256- Farben- Modi als');
  282.   WRITELN('unkomprimiertes LBM- File (Filetyp PBM)');
  283.   WRITELN('Unterstützte Video- Modi :');
  284.   WRITELN(' 13H - VGA Standard 320 * 200 / 256');
  285.   WRITELN(' 2DH - ET 4000      640 * 350 / 256');
  286.   WRITELN(' 2FH - ET 4000      640 * 400 / 256');
  287.   WRITELN(' 2EH - ET 4000      640 * 480 / 256');
  288.   WRITELN(' 30H - ET 4000      800 * 600 / 256');
  289.   WRITELN(' 38H - ET 4000     1024 * 768 / 256');
  290. END; { WASKANNICH }
  291.  
  292.  
  293. BEGIN { MAIN }
  294.  
  295.   IF AlreadyLoaded(SnapID) THEN
  296.     WriteLn(Version, '  ist bereits geladen!',
  297.             ^M^J, 'Aktivieren Sie das Programm mit ',
  298.             HotKeyName, '.')
  299.   ELSE BEGIN
  300.     IF PopUpInstalled (@WRITELBM, Hotkey, 24) THEN BEGIN
  301.       WriteLn(Version, ' installiert.',
  302.               ^M^J, 'Aktivieren Sie das Programm mit ',
  303.               HotKeyName, '.');
  304.       WASKANNICH;
  305.  
  306.       FIXMOD := 0;
  307.       IF PARAMCOUNT > 0 THEN BEGIN
  308.         VAL(PARAMSTR(1),I,J);
  309.         IF J = 0 THEN FIXMOD := I;
  310.       END;
  311.  
  312.       MakeResident(SnapID);
  313.     END ELSE
  314.       WriteLn(Version, '  nicht installiert,', ^M^J,
  315.               'Fehler: Vermutlich zu wenig Hauptspeicher!');
  316.   END;
  317.   WASKANNICH;
  318. END.
  319.  
  320.  
  321.