home *** CD-ROM | disk | FTP | other *** search
/ ftp.barnyard.co.uk / 2015.02.ftp.barnyard.co.uk.tar / ftp.barnyard.co.uk / cpm / walnut-creek-CDROM / CPM / TURBOPAS / SQZTURBO.LBR / SQZ.PAS < prev    next >
Pascal/Delphi Source File  |  2000-06-30  |  8KB  |  214 lines
  1. Program Squeeze;                            (* Written: 01/29/1986  17:31:13 *)
  2.  
  3.  {
  4.  [][][][][][][][][][][][][][][][][][][][][][][][][][][][][][][][][][][][]
  5.  []                        Program Squeeze                             []
  6.  []                                                                    []
  7.  []    A file compression program. Compatible with CP/M or DOS, Turbo  []
  8.  [] Pascal Version 2.0 and above.                                      []
  9.  []                                                                    []
  10.  []                                                                    []
  11.  []                            Bob Berry, CompuServe 76555,167         []
  12.  []                                                                    []
  13.  [][][][][][][][][][][][][][][][][][][][][][][][][][][][][][][][][][][][]
  14.  }
  15.  
  16. Const Version                         = 'Version 2.1  Last Update 01/29/1986';
  17.       PrinterToggle                   = '/P';
  18.       FormFeed                        = ^L;
  19.       Space                           = ' ';
  20.       Error                           = -1;
  21.       Null                            = -2;
  22.       Recognize                       = $FF76;
  23.       DLE                             = #$90;
  24.       SPEOF                           = 256;     { special endfile token }
  25.       NumVals                         = 257;     { 256 data values plus SPEOF }
  26.       NumNodes                        = 513;  { 2*NUMVALS-1 = number of nodes }
  27.       NoChild                         = -1;       { indicates end of path }
  28.       MaxCount                        = MAXINT;   { biggest UNSIGNED integer }
  29.  
  30. Type  FileName                        = String[30];
  31.       ValType                         = Array[0..NumVals] of integer;
  32.       StateTypes                      = (NoHist,SentChar,SendNewC,
  33.                                                 SendCnt,EndFile);
  34.       NodeType                        = Record
  35.                                           Weight: real;
  36.                                           Tdepth: integer;
  37.                                           LChild,
  38.                                           RChild: integer;
  39.                                         end;
  40.       FlePtr                          = ^FileLst;
  41.       FileLst                         = Record
  42.                                           FNme: FileName;
  43.                                           NxtF: FlePtr;
  44.                                         end;
  45.  
  46. Var   InFileName,
  47.       OutFileName,
  48.       FMask,
  49.       DrivePrefix,
  50.       OutDrive:                         FileName;
  51.  
  52.       InFileSize,
  53.       OutFileSize:                      real;
  54.  
  55.       Finish, i,
  56.       Crc,
  57.       DcTreeHd,
  58.       LikeCt:                           integer;
  59.  
  60.       HeapTop:                          ^Integer;
  61.       FFirst, FLast, FCurrent:          FlePtr;
  62.  
  63.       LoggedDrive,
  64.       LastChar, NewChar:                char;
  65.  
  66.       State:                            StateTypes;
  67.  
  68.       PrinterEcho,
  69.       EOFile, EOFlag,
  70.       AllDone, Done:                    boolean;
  71.  
  72.       Node:                             array[0..NumNodes] of NodeType;
  73.  
  74. { This is the encoding table:  The bit strings have first bit in = low bit.
  75.   Note that counts were scaled so code fits UNSIGNED integer }
  76.  
  77.      CodeLen, Code:                     array[0..numvals] of integer;
  78.                        { number of bits in code & code itself, right adjusted }
  79.      TCode,                                            { temporary code value }
  80.      CurIn,                                   { Value currently being encoded }
  81.      CBitsRem,                         { Number of code string bits remaining }
  82.      CCode:                             integer;
  83.                           { Current code shifted so next code bit is at right }
  84.  
  85.  {
  86.  [][][][][][][][][][][][][][][][][][][][][][][][][][][][][][][][][][][][]
  87.  [] Pick one: CP/M or DOS and comment out the one that doesn't apply   []
  88.  [][][][][][][][][][][][][][][][][][][][][][][][][][][][][][][][][][][][]
  89.  }
  90.  
  91. (*
  92. {$I cpm.inc   }
  93. *)
  94. {$I dos.inc    }
  95.  
  96. {$I sqzmain.inc  }
  97.  
  98. Procedure Compress(Var TheString: FileName);
  99.   begin
  100.     While Pos(' ',TheString) > 0 do Delete(TheString,Pos(' ',TheString),1);
  101.   end;   { Procedure Compress }
  102.  
  103. Procedure Squeeze;
  104.   Var C: Char;
  105.   begin
  106.     InFileName:=DrivePrefix+InFileName;
  107.     OutFileName:=InFileName;
  108.     If Length(OutDrive)>0 then OutFileName[1]:=UpCase(OutDrive[1]);
  109.     While (Pos('.',OutFileName)+3)>Length(OutFileName) do
  110.                                               OutFileName:=OutFileName+Space;
  111.     Finish:=succ(Pos('.',OutFileName));
  112.     OutFileName[succ(Finish)]:='Q';
  113.     If OutFileName[Finish]=Space then
  114.       begin
  115.         OutFileName[Finish]:='Q'; OutFileName[succ(succ(Finish))]:='Q';
  116.       end;
  117.  
  118.     Assign(InFile,InFileName);
  119.     Reset(InFile);
  120.     InFileSize:=TheSizeOf(InFile);
  121.     If InFileSize=0 then
  122.       begin
  123.         WriteLn('Input file ',InFileName,' is empty.');
  124.         CloseInFile;
  125.       end
  126.     else
  127.       begin
  128.         WriteLn;
  129.         WriteLn('The file ',InFileName,' (',InFileSize:6:0,
  130.                                  ' bytes ) is being squeezed to ',OutFilename);
  131.  
  132.         InitializeHuffman; WriteLn('.');
  133.         Assign(OutFile,OutFileName); ReWriteOutFile;
  134.         Write('Pass 2: Squeezing,');
  135.         CloseInFile; ResetInFile; EOFile:=false; EOFlag:=false;
  136.         Write(' header,'); WriteHeader;
  137.         Write(' body,');   State:=NoHist;
  138.         Done:=false; C:=GetHuff;
  139.         While not Done do begin WriteOutFile(C); C:=GetHuff; end;
  140.  
  141.         CloseInFile; CloseOutFile;
  142.         OutFileSize:=GetSizeOfOutFile;
  143.  
  144.         WriteLn(' Done.');
  145.         WriteLn('The file ',OutFileName,' is',OutFileSize:6:0,
  146.                           ' bytes (',(100.0*OutFileSize/InFileSize):5:1,'%).');
  147.       end;
  148.   end; { Procedure Squeeze }
  149.  
  150.  {
  151.  [][][][][][][][][][][][][][][][][][][][][][][][][][][][][][][][][][][][]
  152.  []                        Squeeze MainLine                            []
  153.  [][][][][][][][][][][][][][][][][][][][][][][][][][][][][][][][][][][][]
  154.  }
  155.  
  156. begin
  157.   ClrScr; GetLoggedDrive; 
  158.   If CommandLine > '' then                 { Get InFileName from Command Line }
  159.     begin
  160.       WriteLn;
  161.       InFileName:=CommandLine;
  162.       For i:=1 to Length(InFileName) do
  163.         InFileName[i]:=UpCase(InFileName[i]);
  164.       PrinterEcho:= ( Pos(PrinterToggle,InFileName) > 0 );
  165.       If PrinterEcho then
  166.         begin
  167.           SetEchoToPrinter; Delete(InFileName,Pos(PrinterToggle,InFileName),2);
  168.         end;
  169.       Compress(InFileName);
  170.     end
  171.   else
  172.     begin
  173.       InFileName:=''; PrinterEcho:=False;
  174.     end;
  175.  
  176.   Write('File Squeezer');
  177.   For i:=1 to 66-Length(Version) do Write(Space); WriteLn(Version);
  178.  
  179.   Repeat { Until AllDone }
  180.     AllDone:=false;
  181.     If InFileName='' then
  182.       begin
  183.         WriteLn; Write('Enter file to squeeze ( or <cr> to exit ) >');
  184.         ReadLn(InFileName);
  185.         For i:=1 to Length(InFileName) do InFileName[i]:=UpCase(InFileName[i]);
  186.         Compress(InFileName);
  187.       end;
  188.  
  189.     If Pos('.',InFileName)=0 then InFileName:=InFileName+'.';
  190.     If Pos(':',InFileName)=0 then InFileName:=LoggedDrive+':'+InFileName;
  191.     DrivePrefix:=Copy(InFileName,1,2);
  192.     If Length(InFileName)<4 then AllDone:=true    { <== Blank name, AllDone }
  193.     else
  194.       begin
  195.         Mark(HeapTop); FindFiles(InFileName);
  196.  
  197.         If FFirst=Nil then
  198.           WriteLn('Input file(s) ',InFileName,' not found.')
  199.         else
  200.           begin
  201.             Write('Output Drive ( or <cr> for ',DrivePrefix,' ) >');
  202.             ReadLn(OutDrive);
  203.             Repeat { Until InFileName='' }
  204.               InFileName:=NextFile;
  205.               If InFileName > '' then Squeeze;
  206.             Until InFileName='';
  207.           end;
  208.  
  209.         Release(HeapTop);
  210.       end;
  211.     InFileName:='';
  212.   Until AllDone;
  213.   If PrinterEcho then Write(Lst,FormFeed);
  214. end.