home *** CD-ROM | disk | FTP | other *** search
/ Collection of Hack-Phreak Scene Programs / cleanhpvac.zip / cleanhpvac / AMOD095.ZIP / BIN2PACK.PAS < prev    next >
Pascal/Delphi Source File  |  1995-04-12  |  3KB  |  168 lines
  1. uses crt;
  2. const
  3. lines : integer = 50;
  4.  
  5. var
  6. pic,pic2 : array[0..8000] of byte;
  7. f1 : file;
  8. f2 : text;
  9. count2,len : word;
  10. count : word;
  11. attr : byte;
  12.  
  13. procedure putch(b : byte);
  14. begin
  15.   pic2[count2] := b;
  16.   inc(count2);
  17. end;
  18.  
  19. function getch : byte;
  20. begin
  21.   getch := pic2[count2];
  22.   inc(count2);
  23. end;
  24.  
  25. function countb(b,attr : byte) : integer;
  26. var
  27. n : integer;
  28. begin
  29.   n := 0;
  30.   while (pic[(count+n)*2]=b) and (pic[(count+n)*2+1]=attr) do begin
  31.     inc(n);
  32.   end;
  33.   if n > 250 then n := 250;
  34.   countb := n;
  35. end;
  36.  
  37. procedure pack;
  38. var
  39. b,b2 : byte;
  40. n : integer;
  41. begin
  42.   len := 0;
  43.   attr := pic[1];
  44.   count := 0;
  45.   count2 := 0;
  46.   putch(1);
  47.   putch(attr);
  48.   while count < lines*80 do begin
  49.     b := pic[count*2];
  50.     b2 := pic[count*2+1];
  51.     if b2 <> attr then begin
  52.       putch(1);
  53.       putch(b2);
  54.       attr := b2;
  55.     end;
  56.     n := 0;
  57.     n := countb(b,attr);
  58.     if n > 1 then begin
  59.       if b = 32 then begin
  60.         putch(3);
  61.         putch(n);
  62.         inc(count,n-1)
  63.       end
  64.       else begin
  65.         putch(2);
  66.         putch(n);
  67.         putch(b);
  68.         inc(count,n-1);
  69.       end;
  70.     end
  71.     else if b < 8 then begin
  72.       putch(7);
  73.       putch(b);
  74.     end
  75.     else putch(b);
  76.     inc(count);
  77.   end;
  78.   putch(0);
  79.   len := count2;
  80. end;
  81.  
  82. procedure putpic(b : byte);
  83. begin
  84.   pic[count*2] := b;
  85.   pic[count*2+1] := attr;
  86.   memw[$b800:count*2] := attr*256+b;
  87.   inc(count);
  88. end;
  89.  
  90. procedure unpack;
  91. var
  92. b,b2 : byte;
  93. n : integer;
  94. begin
  95.   attr := 7;
  96.   count := 0;
  97.   count2 := 0;
  98.   while b <> 0 do begin
  99.     b := getch;
  100.     if b = 1 then begin
  101.       attr := getch;
  102.     end
  103.     else if b = 2 then begin
  104.       b2 := getch;
  105.       b := getch;
  106.       for n := 1 to b2 do putpic(b);
  107.     end
  108.     else if b = 3 then begin
  109.       b2 := getch;
  110.       for n := 1 to b2 do putpic(32);
  111.     end
  112.     else if b = 7 then begin
  113.       b := getch;
  114.       putch(b);
  115.     end
  116.     else putpic(b);
  117.   end;
  118. end;
  119.  
  120. procedure save;
  121. var
  122. n : integer;
  123. x : integer;
  124. begin
  125.   x := 1;
  126.   writeln(f2,'const');
  127.   writeln(f2,'imagedata_len = ',len,';');
  128.   writeln(f2,'imagedata : array[0..',len-1,'] of byte = (');
  129.   for n := 1 to len-1 do begin
  130.     write(f2,pic2[n-1],',');
  131.     inc(x);
  132.     if x > 12 then begin
  133.       x := 1;
  134.       writeln(f2);
  135.     end;
  136.   end;
  137.   writeln(f2,pic2[len-1],');');
  138. end;
  139.  
  140. var
  141. i : integer;
  142.  
  143. begin
  144.   if paramcount < 2 then exit;
  145.   textmode(co80 +font8x8);
  146.   assign(f1,paramstr(1));
  147.   assign(f2,paramstr(2));
  148.   if paramcount > 2 then val(paramstr(3),lines,i);
  149.   reset(f1,1);
  150.   rewrite(f2);
  151.   fillchar(pic,8000,0);
  152.   blockread(f1,pic,lines*160);
  153.   fillchar(pic2,8000,0);
  154.   move(pic,mem[$b800:0],8000);
  155.   readkey;
  156.   pack;
  157.   clrscr;
  158.   fillchar(pic,8000,0);
  159.   unpack;
  160.   {move(pic[0],mem[$b800:0],8000);}
  161.   readkey;
  162.   save;
  163.   close(f1);
  164.   close(f2);
  165.   textmode(co80);
  166.   writeln(len);
  167. end.
  168.