Syntax10.Scn.Fnt
MODULE Compress; (* (c) ejz, first version: 14.1.92, this version: 30.11.94 *)
	IMPORT Files, Texts, Oberon, MenuViewers, TextFrames, Viewers;
		CONST
			BufferSize = 8192;
			IndexBitCount = 12;
			LengthBitCount = 4;
			WindowSize = 4096;
			RawLookAheadSize = 16;
			BreakEven = 1;
			LookAheadSize = RawLookAheadSize + BreakEven;
			TreeRoot = WindowSize;
			EndOfStream = 0;
			Unused = 0;
			Temp = "temp.temp";
			err1 = "Error in archive";
			err2 = " not found";
			err3 = " Archive to big";
			err4 = "Filename to long, can not append .bak";
			DirMenu = "System.Close System.Grow Compress.Open Compress.Extract Compress.Delete Compress.Add";
			EditMenu = "System.Close System.Copy System.Grow Edit.Search Edit.Store";
			maxFileSize = 3000000;
			xx = 32768;
			Menu = 0;
			Cmd = 1;
			EOFName = "~ ";
		TYPE
			Node = RECORD
				parent , smallerChild, largerChild: INTEGER
			END;
			fName = ARRAY 32 OF CHAR;
			Header = RECORD
				Name: fName;
				length, Check: LONGINT;
				date, time: LONGINT;
				ratio: REAL
			END;
			List = POINTER TO ListDesc;
			ListDesc = RECORD
				Name: fName;
				next: List
			END;
			AddList = POINTER TO AddListDesc;
			AddListDesc = RECORD
				Name: fName;
				next: AddList;
				pos: LONGINT
			END;
		VAR
			W: Texts.Writer;
			Buffer: ARRAY BufferSize OF CHAR;
			BufferPtr, CurBitNr, Len, maxLen: LONGINT;
			CurByte: LONGINT;
			Window: ARRAY WindowSize+RawLookAheadSize+1 OF CHAR;
			Tree: POINTER TO ARRAY WindowSize+1 OF Node;
			Err, opt, sym: BOOLEAN;
			T: Texts.Text;
			cmdSource: INTEGER;
			help : INTEGER;
		PROCEDURE WriteString(str: ARRAY OF CHAR);
		BEGIN
			Texts.WriteString(W, str);
			Texts.Append(T, W.buf)
		END WriteString;
		PROCEDURE WriteLn;
		BEGIN
			Texts.WriteLn(W);
			Texts.Append(T, W.buf)
		END WriteLn;
		PROCEDURE WriteInt(i: LONGINT);
		BEGIN
			Texts.WriteInt(W, i, 0);
			Texts.Append(T, W.buf)
		END WriteInt;
		PROCEDURE WriteReal(r: REAL);
		BEGIN
			Texts.WriteReal(W, r, 10);
			Texts.Append(T, W.buf)
		END WriteReal;
		PROCEDURE WriteDate(t, d: LONGINT);
		BEGIN
			Texts.WriteDate(W, t, d);
			Texts.Append(T, W.buf)
		END WriteDate;
		PROCEDURE ReadHeader(VAR R: Files.Rider; VAR h: Header; VAR err: BOOLEAN);
			VAR
				i: INTEGER;
				chk: LONGINT;
		BEGIN
			Files.ReadBytes(R, h.Name, 32);
			IF R.eof & (R.res = 32) THEN
				h.Name := EOFName;
				err := FALSE;
				RETURN
			END;
			Files.ReadLInt(R, h.length);
			Files.ReadLInt(R, h.Check);
			Files.ReadLInt(R, h.date);
			Files.ReadLInt(R, h.time);
			Files.ReadReal(R, h.ratio);
			IF (h.ratio > 0.0) & (h.ratio < 1000000.0) THEN
				i := 0;
				chk := 0;
				WHILE i < 32 DO
					chk := chk+ORD(h.Name[i]);
					INC(i)
				END;
				chk := chk+h.length+ENTIER(h.ratio)+(h.time MOD xx)+(h.date MOD xx);
				err := chk # h.Check
			ELSE
				err := TRUE
			END
		END ReadHeader;
		PROCEDURE WriteHeader(VAR R: Files.Rider; VAR h: Header; newDate: BOOLEAN);
			VAR i: INTEGER;
		BEGIN
			h.Check := 0;
			i := 0;
			WHILE i < 32 DO
				h.Check := h.Check + ORD(h.Name[i]);
				INC(i)
			END;
			IF newDate THEN
				Oberon.GetClock(h.time, h.date)
			END;
			h.Check := h.Check+h.length+(h.time MOD xx)+(h.date MOD xx)+ENTIER(h.ratio);
			Files.WriteBytes(R, h.Name, 32);
			Files.WriteLInt(R, h.length);
			Files.WriteLInt(R, h.Check);
			Files.WriteLInt(R, h.date);
			Files.WriteLInt(R, h.time);
			Files.WriteReal(R, h.ratio)
		END WriteHeader;
		PROCEDURE CopyFrom(VAR Ri, Ro: Files.Rider; len: LONGINT);
			VAR i: LONGINT;
		BEGIN
			Files.ReadBytes(Ri, Buffer, BufferSize);
			i := BufferSize;
			WHILE i <= len DO
				Files.WriteBytes(Ro, Buffer, BufferSize);
				Files.ReadBytes(Ri, Buffer, BufferSize);
				INC(i, BufferSize)
			END;
			Files.WriteBytes(Ro, Buffer, len MOD BufferSize)
		END CopyFrom;
		PROCEDURE CopyTo(VAR Ri, Ro: Files.Rider);
		BEGIN
			Files.ReadBytes(Ri, Buffer, BufferSize);
			WHILE ~Ri.eof DO
				Files.WriteBytes(Ro, Buffer, BufferSize);
				Files.ReadBytes(Ri, Buffer, BufferSize)
			END;
			Files.WriteBytes(Ro, Buffer, BufferSize-Ri.res)
		END CopyTo;
		PROCEDURE FlushBits(VAR R: Files.Rider);
		BEGIN
			IF CurBitNr # 7 THEN
				Buffer[BufferPtr] := CHR(CurByte);
				INC(BufferPtr)
			END;
			IF BufferPtr > 0 THEN
				Files.WriteBytes(R, Buffer, BufferPtr);
				INC(Len, BufferPtr)
			END
		END FlushBits;
		PROCEDURE InputBit(VAR R: Files.Rider): LONGINT;
			VAR h: LONGINT;
		BEGIN
			IF CurBitNr = 7 THEN
				IF BufferPtr = BufferSize THEN
					Files.ReadBytes(R, Buffer, BufferSize);
					INC(Len, BufferSize);
					IF Len >= maxLen+ BufferSize THEN Err := TRUE END;
					BufferPtr := 0
				END;
				CurByte := ORD(Buffer[BufferPtr]);
				INC(BufferPtr)
			END;
			h := ASH(CurByte, -CurBitNr) MOD 2;
			DEC(CurBitNr);
			IF CurBitNr < 0 THEN CurBitNr := 7 END;
			RETURN h
		END InputBit;
		PROCEDURE InputBits(VAR R: Files.Rider; count: LONGINT): LONGINT;
			VAR i, h: LONGINT;
		BEGIN
			h := 0;
			i := count-1;
			WHILE i >= 0 DO
				IF CurBitNr = 7 THEN
					IF BufferPtr = BufferSize THEN
						Files.ReadBytes(R, Buffer, BufferSize);
						INC(Len, BufferSize);
						IF Len > maxLen+ BufferSize THEN Err := TRUE END;
						BufferPtr := 0
					END;
					CurByte := ORD(Buffer[BufferPtr]);
					INC(BufferPtr)
				END;
				IF ASH(CurByte, -CurBitNr) MOD 2 = 1 THEN
					h := h+ASH(1, i)
				END;
				DEC(CurBitNr);
				IF CurBitNr < 0 THEN CurBitNr := 7 END;
				DEC(i)
			END;
			RETURN h
		END InputBits;
		PROCEDURE OutputBit(VAR R: Files.Rider; bit: LONGINT);
		BEGIN
			IF bit = 1 THEN
				CurByte := CurByte+ASH(1, CurBitNr)
			END;
			DEC(CurBitNr);
			IF CurBitNr < 0 THEN
				Buffer[BufferPtr] := CHR(CurByte);
				INC(BufferPtr);
				IF BufferPtr = BufferSize THEN
					Files.WriteBytes(R,  Buffer, BufferSize);
					INC(Len, BufferSize);
					BufferPtr := 0
				END;
				CurBitNr := 7;
				CurByte := 0
			END
		END OutputBit;
		PROCEDURE OutputBits(VAR R: Files.Rider; bits, count: LONGINT);
			VAR i, h: LONGINT;
		BEGIN
			h := bits;
			i := count-1;
			WHILE i >= 0 DO
				IF ASH(h, -i) MOD 2 = 1 THEN
					CurByte := CurByte+ASH(1, CurBitNr)
				END;
				DEC(CurBitNr);
				IF CurBitNr < 0 THEN
					Buffer[BufferPtr] := CHR(CurByte);
					INC(BufferPtr);
					IF BufferPtr = BufferSize THEN
						Files.WriteBytes(R, Buffer, BufferSize);
						INC(Len, BufferSize);
						BufferPtr := 0
					END;
					CurBitNr := 7;
					CurByte := 0
				END;
				DEC(i)
			END
		END OutputBits;
		PROCEDURE Init;
			VAR i: INTEGER;
		BEGIN
			i := 0;
			WHILE i < WindowSize DO
				Tree[i].parent := Unused;
				Tree[i].smallerChild := Unused;
				Tree[i].largerChild := Unused;
				Window[i] := CHR(0);
				INC(i)
			END;
			Tree[i].parent := Unused;
			Tree[i].smallerChild := Unused;
			Tree[i].largerChild := Unused;
			WHILE i < WindowSize+RawLookAheadSize+1 DO
				Window[i] := CHR(0);
				INC(i)
			END
		END Init;
		PROCEDURE InitTree(r: INTEGER);
		BEGIN
			Tree[TreeRoot].largerChild := r;
			Tree[r].parent := TreeRoot;
			Tree[r].largerChild := Unused;
			Tree[r].smallerChild := Unused
		END InitTree;
		PROCEDURE ContractNode(oldNode, newNode: INTEGER);
		BEGIN
			help := Tree[oldNode].parent;
			Tree[newNode].parent := help;
			help := Tree[oldNode].parent;
			IF Tree[help].largerChild = oldNode THEN
				Tree[help].largerChild := newNode
			ELSE
				Tree[help].smallerChild := newNode
			END;
			Tree[oldNode].parent := Unused
		END ContractNode;
		PROCEDURE ReplaceNode(oldNode, newNode: INTEGER);
			VAR parent: INTEGER;
		BEGIN
			parent := Tree[oldNode].parent;
			IF Tree[parent].smallerChild = oldNode THEN
				Tree[parent].smallerChild := newNode
			ELSE
				Tree[parent].largerChild := newNode
			END;
			Tree[newNode] := Tree[oldNode];
			help := Tree[newNode].smallerChild;
			Tree[help].parent := newNode;
			help := Tree[newNode].largerChild;
			Tree[help].parent := newNode;
			Tree[oldNode].parent := Unused
		END ReplaceNode;
		PROCEDURE FindNextNode(node: INTEGER): INTEGER;
			VAR next: INTEGER;
		BEGIN
			next := Tree[node].smallerChild;
			WHILE Tree[next].largerChild # Unused DO
				next := Tree[next].largerChild
			END;
			RETURN next
		END FindNextNode;
		PROCEDURE DeleteString(p: INTEGER);
			VAR replacement: INTEGER;
		BEGIN
			IF Tree[p].parent = Unused THEN
				RETURN
			END;
			IF Tree[p].largerChild = Unused THEN
				ContractNode(p, Tree[p].smallerChild)
			ELSIF Tree[p].smallerChild = Unused THEN
				ContractNode(p, Tree[p].largerChild)
			ELSE
				replacement := FindNextNode(p);
				DeleteString(replacement);
				ReplaceNode(p, replacement)
			END
		END DeleteString;
		PROCEDURE AddString(newNode: INTEGER; VAR matchPosition: INTEGER): INTEGER;
			VAR i, testNode, delta, matchLength, child: INTEGER;
		BEGIN
			IF newNode = EndOfStream THEN
				RETURN 0
			END;
			testNode := Tree[TreeRoot].largerChild;
			matchLength := 0;
			LOOP
				i := 0;
				delta := 0;
				WHILE (i < LookAheadSize) & (delta = 0) DO
					delta := ORD(Window[newNode+i]) - ORD(Window[testNode+i]);
					INC(i)
				END;
				IF delta # 0 THEN DEC(i) END;
				IF i >= matchLength THEN
					matchLength := i;
					matchPosition := testNode;
					IF matchLength >= LookAheadSize THEN
						ReplaceNode(testNode, newNode);
						RETURN matchLength
					END;
				END;
				IF delta >= 0 THEN
					child := Tree[testNode].largerChild
				ELSE
					child := Tree[testNode].smallerChild
				END;
				IF child = Unused THEN
					IF delta >= 0 THEN
						Tree[testNode].largerChild := newNode
					ELSE
						Tree[testNode].smallerChild := newNode
					END;
					Tree[newNode].parent := testNode;
					Tree[newNode].largerChild := Unused;
					Tree[newNode].smallerChild := Unused;
					RETURN matchLength
				END;
				testNode := child
			END
		END AddString;
		PROCEDURE Compress(VAR Input, Output: Files.Rider);
			VAR
				i, lookAheadBytes, currentPosition, replaceCount, matchLength, matchPosition: INTEGER;
				ch: CHAR;
		BEGIN
			Init;
			currentPosition := 1;
			i := 0;
			WHILE (i < LookAheadSize) & ~Input.eof DO
				Files.Read(Input, ch);
				Window[currentPosition+i] := ch;
				IF currentPosition+i < RawLookAheadSize+1 THEN
					Window[currentPosition+i+WindowSize-1] := ch
				END;
				INC(i)
			END;
			IF Input.eof THEN DEC(i) END;
			lookAheadBytes := i;
			InitTree(currentPosition);
			matchLength := 0;
			matchPosition := 0;
			WHILE lookAheadBytes > 0 DO
				IF matchLength > lookAheadBytes THEN
					matchLength := lookAheadBytes
				END;
				IF matchLength <= BreakEven THEN
					replaceCount := 1;
					OutputBit(Output, 1);
					OutputBits(Output, ORD(Window[currentPosition]), 8)
				ELSE
					OutputBit(Output, 0);
					OutputBits(Output, matchPosition, IndexBitCount);
					OutputBits(Output, matchLength-(BreakEven+1), LengthBitCount);
					replaceCount := matchLength
				END;
				i := 0;
				WHILE i < replaceCount DO
					DeleteString((currentPosition+LookAheadSize) MOD (WindowSize-1));
					Files.Read(Input, ch);
					IF Input.eof THEN
						DEC(lookAheadBytes)
					ELSE
						Window[currentPosition+LookAheadSize] := ch;
						Window[(currentPosition+LookAheadSize) MOD (WindowSize-1)] := ch
					END;
					currentPosition := (currentPosition+1) MOD (WindowSize-1);
					IF lookAheadBytes # 0 THEN
						matchLength := AddString(currentPosition, matchPosition)
					END;
					INC(i)
				END
			END;
			OutputBit(Output, 0);
			OutputBits(Output, EndOfStream, IndexBitCount)
		END Compress;
		PROCEDURE Expand(VAR Input, Output: Files.Rider);
			VAR
				i, currentPosition, matchLength, matchPosition: INTEGER;
				ch: CHAR;
		BEGIN
			Err := FALSE;
			Init;
			currentPosition := 1;
			LOOP
				IF InputBit(Input) # 0 THEN
					ch := CHR(InputBits(Input, 8));
					Files.Write(Output, ch);
					Window[currentPosition] := ch;
					IF currentPosition < RawLookAheadSize+1 THEN
						Window[currentPosition+WindowSize-1] := ch
					END;
					currentPosition := (currentPosition+1) MOD (WindowSize-1)
				ELSE
					matchPosition := SHORT(InputBits(Input, IndexBitCount));
					IF matchPosition = EndOfStream THEN EXIT END;
					matchLength := SHORT(InputBits(Input, LengthBitCount));
					INC(matchLength, BreakEven);
					i := 0;
					WHILE i <= matchLength DO
						ch := Window[matchPosition+i];
						Files.Write(Output, ch);
						Window[currentPosition] := ch;
						IF currentPosition < RawLookAheadSize+1 THEN
							Window[currentPosition+WindowSize-1] := ch;
						END;
						currentPosition := (currentPosition+1) MOD (WindowSize-1);
						INC(i)
					END
				END;
				IF Err THEN RETURN END
			END
		END Expand;
		PROCEDURE CopyToArc(VAR f: Files.File; VAR Ro: Files.Rider; VAR ratio: REAL): LONGINT;
			VAR Ri: Files.Rider;
		BEGIN
			Files.Set(Ri, f, 0);
			Len := 0;
			BufferPtr := 0;
			CurBitNr := 7;
			CurByte := 0;
			Compress(Ri, Ro);
			FlushBits(Ro);
			ratio := 100*Len/Files.Length(f);
			RETURN Len
		END CopyToArc;
		PROCEDURE CopyFromArc(VAR Ri: Files.Rider; VAR f: Files.File; len: LONGINT);
			VAR Ro: Files.Rider;
		BEGIN
			maxLen := len;
			Files.Set(Ro, f, 0);
			Len := 0;
			BufferPtr := BufferSize;
			CurBitNr := 7;
			CurByte := 0;
			Expand(Ri, Ro);
			IF Err THEN
				WriteString("Error expanding");
				WriteLn
			END
		END CopyFromArc;
		PROCEDURE StringLen(str: ARRAY OF CHAR): INTEGER;
			VAR i: INTEGER;
		BEGIN
			i := 0;
			WHILE (i < LEN(str)) & (str[i] # CHR(0)) DO
				INC(i)
			END;
			RETURN i
		END StringLen;
		PROCEDURE UpString(VAR str: ARRAY OF CHAR);
			VAR i: INTEGER;
		BEGIN
			i := 0;
			WHILE i < StringLen(str) DO
				IF (str[i] >= "a") & (str[i] <= "z") THEN
					str[i] := CHR(ORD(str[i])+ORD("A")-ORD("a"))
				END;
				INC(i)
			END
		END UpString;
		PROCEDURE StringConcat(VAR dest: ARRAY OF CHAR; a: ARRAY OF CHAR);
			VAR i, j: INTEGER;
		BEGIN
			i := StringLen(dest);
			j :=  0;
			WHILE (i < LEN(dest)) & (j < StringLen(a)) DO
				dest[i] := a[j];
				INC(i);
				INC(j)
			END;
			IF i < LEN(dest) THEN dest[i] := CHR(0) END
		END StringConcat;
		PROCEDURE Search(NameList: List; VAR Name: fName): List;
		BEGIN
			WHILE NameList # NIL DO
				IF NameList.Name = Name THEN RETURN NameList END;
				NameList := NameList.next
			END;
			RETURN NIL
		END Search;
		PROCEDURE SearchA(NameList: AddList; VAR Name: fName): AddList;
		BEGIN
			WHILE NameList # NIL DO
				IF NameList.Name = Name THEN RETURN NameList END;
				NameList := NameList.next
			END;
			RETURN NIL
		END SearchA;
		PROCEDURE Remove(VAR NameList: List; VAR Name: fName);
			VAR cur, prev: List;
		BEGIN
			cur := NameList.next;
			prev := NameList;
			WHILE cur # NIL DO
				IF cur.Name = Name THEN
					prev.next := cur.next;
					RETURN
				ELSE
					prev := cur
				END;
				cur := cur.next
			END
		END Remove;
		PROCEDURE GetArcName(VAR name: fName);
			VAR
				V: Viewers.Viewer;
				S: Texts.Scanner;
		BEGIN
			V := Oberon.Par.vwr;
			IF (V.dsc IS TextFrames.Frame) & (V.dsc = Oberon.Par.frame) THEN
				Texts.OpenScanner(S, V.dsc(TextFrames.Frame).text, 0);
				Texts.Scan(S);
				IF S.class = Texts.Name THEN
					cmdSource := Menu;
					COPY(S.s, name);
					RETURN
				END
			END;
			cmdSource := Cmd;
			name := EOFName
		END GetArcName;
		PROCEDURE GetText(): Texts.Text;
			VAR
				V: Viewers.Viewer;
		BEGIN
			V := Oberon.Par.vwr;
			IF (V = NIL) OR (V.dsc = NIL) OR (V.dsc.next = NIL) THEN
				RETURN NIL
			ELSIF V.dsc.next IS TextFrames.Frame THEN
				RETURN V.dsc.next(TextFrames.Frame).text
			ELSE
				RETURN NIL
			END
		END GetText;
		PROCEDURE GetArgs(VAR NameList: List);
			VAR
				h, last: List;
				S: Texts.Scanner;
				mn: fName;
				arrow: BOOLEAN;
				T: Texts.Text;
				beg, end, time, pos: LONGINT;
		BEGIN
			pos := 0;
			end := 0;
			arrow := FALSE;
			NameList := NIL;
			last := NIL;
			GetArcName(mn);
			IF mn # EOFName THEN
				arrow := TRUE;
				NEW(h);
				h.next := NIL;
				COPY(mn, h.Name);
				NameList := h;
				last := NameList;
				Oberon.GetSelection(T, beg, end, time);
				IF time > 0 THEN
					Texts.OpenScanner(S, T, beg); pos := beg; Texts.Scan(S)
				ELSE
					RETURN
				END
			ELSE
				Texts.OpenScanner(S, Oberon.Par.text, Oberon.Par.pos);
				Texts.Scan(S);
				IF (S.class = Texts.Char) & (S.c = "^") THEN
					arrow := TRUE;
					Oberon.GetSelection(T, beg, end, time);
					IF time > 0 THEN
						Texts.OpenScanner(S, T, beg); pos := beg; Texts.Scan(S)
					ELSE
						RETURN
					END
				END
			END;
			WHILE ((cmdSource = Menu) &  (pos <= end+StringLen(S.s))) OR
								((cmdSource = Cmd) & (S.class = Texts.Name) & (~arrow OR (arrow & (pos <= end+StringLen(S.s))))) DO
				NEW(h);
				h.next := NIL;
				COPY(S.s, h.Name);
				IF Search(NameList, h.Name) = NIL THEN
					IF last = NIL THEN
						NameList := h
					ELSE
						last.next := h
					END;
					last := h
				END;
				Texts.Scan(S);
				IF ~arrow & (S.class = Texts.Char) & (S.c = "^") THEN
					arrow := TRUE;
					Oberon.GetSelection(T, beg, end, time);
					IF time > 0 THEN
						Texts.OpenScanner(S, T, beg); Texts.Scan(S)
					END
				END;
				pos := Texts.Pos(S)
			END;
			IF cmdSource = Menu THEN
				opt := TRUE
			ELSE
				opt := FALSE;
					IF (S.class = Texts.Char) & ((S.c = "/") OR (S.c = "\")) THEN
						Texts.Scan(S);
						IF (S.class = Texts.Name) & (S.s[0] = "d") THEN opt := TRUE END;
					END
			END
		END GetArgs;
		PROCEDURE OpenArchive(VAR NameList: List; warn: BOOLEAN): Files.File;
			VAR ArcF: Files.File;
		BEGIN
			ArcF := Files.Old(NameList.Name);
			IF (ArcF = NIL) & warn THEN
				WriteString("archive: ");
				WriteString(NameList.Name);
				WriteString(err2);
				WriteLn
			END;
			RETURN ArcF
		END OpenArchive;
		PROCEDURE Trimm(VAR name: ARRAY OF CHAR);
			VAR
				l, i, j: LONGINT;
				back: fName;
				ch: CHAR;
		BEGIN
			l := LEN(name);
			j := -1;
			i := 0;
			WHILE (i < l) & (name[i] # 0X) DO
				ch := name[i];
				IF (ch = "/") OR (ch = "\") THEN
					j := i
				END;
				INC(i)
			END;
			IF j >= 0 THEN
				COPY(name, back);
				j := j+1;
				i := 0;
				WHILE (j < l) & (back[j] # 0X) DO
					name[i] := back[j];
					INC(i);
					INC(j)
				END;
				name[i] := 0X
			END
		END Trimm;
	PROCEDURE NextName(VAR name: ARRAY OF CHAR);
		VAR
			i, l: LONGINT;
			ch: CHAR;
	BEGIN
		l := LEN(name);
		i := 0;
		WHILE (i < l) & (name[i] # 0X) DO
			INC(i)
		END;
		IF i >= l THEN
			name[l-1] := CHR(ORD(name[l-1])+1)
		ELSE
			ch := name[i-1];
			IF (ch >= "0") & (ch <= "8") THEN
				name[i-1] := CHR(ORD(name[i-1])+1)
			ELSE
				name[i] := "0";
				IF (i+1) < l THEN
					name[i+1] := 0X
				END
			END
		END
	END NextName;
		PROCEDURE Directory*;
			VAR
				NameList: List;
				ArcF: Files.File;
				R: Files.Rider;
				h: Header;
				err, newViewer: BOOLEAN;
				x, y, n: INTEGER;
				V: MenuViewers.Viewer;
				t: Texts.Text;
				totRatio: REAL;
		BEGIN
			GetArgs(NameList);
			IF NameList = NIL THEN
				RETURN
			END;
			ArcF := OpenArchive(NameList, TRUE);
			err := FALSE;
			IF ArcF = NIL THEN
				RETURN
			ELSE
				IF cmdSource = Menu THEN
					t := GetText()
				ELSE
					t := NIL
				END;
				IF t = NIL THEN
					NEW(t);
					t := TextFrames.Text("");
					newViewer := TRUE
				ELSE
					newViewer := FALSE;
					Texts.Delete(t, 0, t.len)
				END;
				T := t;
				n := 0;
				totRatio := 0.0;
				Files.Set(R, ArcF, 0);
				ReadHeader(R, h, err);
				WHILE (h.Name # EOFName) & ~err DO
					WriteString(h.Name);
					IF opt THEN
						WriteString("  ");
						WriteDate(h.time, h.date);
						WriteString("   ");
						WriteInt(h.length);
						WriteString("  ");
						WriteReal(h.ratio);
						WriteString("% ")
					END;
					WriteLn;
					INC(n);
					totRatio := totRatio+h.ratio;
					Files.Set(R, ArcF, Files.Pos(R)+h.length);
					ReadHeader(R, h, err)
				END
			END;
			IF ArcF = NIL THEN
				WriteString(NameList.Name);
				WriteString(err2);
				WriteLn;
				RETURN
			END;
			IF Files.Pos(R) = 0 THEN
				WriteString("Archive is empty");
				WriteLn
			ELSE
				WriteLn;
				IF opt & ~err THEN
					WriteString("Average: ");
					WriteReal(totRatio/n);
					WriteString("% ");
					WriteString(", Size: ");
					WriteInt(Files.Length(ArcF));
					WriteString(" Bytes");
					WriteLn
				END
			END;
			IF err THEN
				WriteString(err1);
				WriteLn
			END;
			IF newViewer THEN
				Oberon.AllocateUserViewer(Oberon.Mouse.X, x, y);
				V := MenuViewers.New(TextFrames.NewMenu(NameList.Name, DirMenu),
						TextFrames.NewText(t, 0), TextFrames.menuH, x, y);
				V.dsc.next.handle := TextFrames.Handle
			END;
			T := Oberon.Log;
			IF ArcF # NIL THEN Files.Close(ArcF) END
		END Directory;
		PROCEDURE Add*;
			VAR
				nl, NameList: List;
				addL, ha: AddList;
				new, err, changed: BOOLEAN;
				ArcF, AddF: Files.File;
				R: Files.Rider;
				h: Header;
				ver: INTEGER;
				pos, len: LONGINT;
		BEGIN
			GetArgs(NameList);
			IF (NameList = NIL) OR (NameList.next = NIL) THEN
				RETURN
			END;
			new := FALSE;
			ArcF := OpenArchive(NameList, FALSE);
			IF ArcF = NIL THEN
				WriteString("New archive");
				WriteLn;
				new := TRUE;
				ArcF := Files.New(NameList.Name)
			END;
			WriteString("Compress.Add ");
			WriteString(NameList.Name);
			WriteLn;
			changed := FALSE;
			Files.Set(R, ArcF, 0);
			addL := NIL;
			pos := Files.Pos(R);
			ReadHeader(R, h, err);
			WHILE (h.Name # EOFName) & ~err DO
				IF addL = NIL THEN
					NEW(addL);
					addL.Name := h.Name;
					addL.pos := pos;
					addL.next := NIL
				ELSE
					NEW(ha);
					ha.Name := h.Name;
					ha.pos := pos;
					ha.next := addL;
					addL := ha
				END;
				Files.Set(R, ArcF, Files.Pos(R)+h.length);
				pos := Files.Pos(R);
				ReadHeader(R, h, err)
			END;
			IF err THEN
				WriteString(err1);
				WriteLn;
				Files.Close(ArcF);
				RETURN
			END;
			IF NameList.next # NIL THEN
				h.length := 0;
				nl := NameList.next;
				WHILE nl # NIL DO
					AddF := Files.Old(nl.Name);
					IF AddF = NIL THEN
						WriteString("    ");
						WriteString(nl.Name);
						WriteString(err2);
						WriteLn
					ELSE
						Trimm(nl.Name);
						IF (Files.Length(ArcF) + Files.Length(AddF)) >= maxFileSize THEN
							Files.Close(AddF);
							nl.next := NIL;
							WriteString(err3);
							WriteLn
						ELSE
							IF SearchA(addL, nl.Name) # NIL THEN
								WHILE SearchA(addL, nl.Name) # NIL DO
									NextName(nl.Name)
								END
							END;
							Files.Set(R, ArcF, Files.Length(ArcF));
							pos := Files.Pos(R);
							COPY(nl.Name, h.Name);
							WriteString("    ");
							WriteString(nl.Name);
							WriteLn;
							changed := TRUE;
							h.ratio := 0.0;
							WriteHeader(R, h, TRUE);
							len := CopyToArc(AddF, R, h.ratio);
							h.length := len;
							Files.Close(AddF);
							Files.Set(R, ArcF, pos);
							WriteHeader(R, h, TRUE);
							NEW(ha);
							ha.Name := nl.Name;
							ha.pos := pos;
							ha.next := addL;
							addL := ha
						END
					END;
					nl := nl.next
				END
			END;
			IF new THEN
				Files.Register(ArcF)
			ELSE
				Files.Close(ArcF)
			END;
			IF changed & (cmdSource=Menu) THEN Directory END
		END Add;
		PROCEDURE Delete*;
			TYPE
				DelList = POINTER TO DelListDesc;
				DelListDesc = RECORD
					start, end: LONGINT;
					next, prev: DelList
				END;
			VAR
				NameList, nl: List;
				DeleteList, last, dl: DelList;
				ArcF, TmpF: Files.File;
				R, Rt: Files.Rider;
				h: Header;
				pos, beg: LONGINT;
				res: INTEGER;
				err, changed: BOOLEAN;
		BEGIN
			GetArgs(NameList);
			IF (NameList = NIL) OR (NameList.next = NIL) THEN
				RETURN
			END;
			ArcF := OpenArchive(NameList, TRUE);
			IF ArcF = NIL THEN
				RETURN
			END;
			DeleteList := NIL;
			last := NIL;
			changed := FALSE;
			WriteString("Compress.Delete ");
			WriteString(NameList.Name);
			WriteLn;
			Files.Set(R, ArcF, 0);
			beg := 0;
			ReadHeader(R, h, err);
			WHILE (h.Name # EOFName) & (NameList.next # NIL) & ~err DO
				pos := Files.Pos(R);
				IF Search(NameList, h.Name) # NIL THEN
					NEW(dl);
					dl.start := beg;
					dl.end := pos+h.length;
					dl.next := NIL;
					IF last = NIL THEN
						DeleteList := dl;
					ELSE
						last.next := dl
					END;
					last := dl;
					WriteString("    ");
					WriteString(h.Name);
					WriteLn;
					Remove(NameList, h.Name)
				END;
				Files.Set(R, ArcF, pos+h.length);
				beg := pos+h.length;
				ReadHeader(R, h, err)
			END;
			Files.Close(ArcF);
			nl := NameList.next;
			WHILE nl # NIL DO
				WriteString("    ");
				WriteString(nl.Name);
				WriteString(err2);
				WriteLn;
				nl := nl.next
			END;
			IF err THEN
				WriteString(err1);
				WriteLn
			END;
			IF DeleteList # NIL THEN
				changed := TRUE;
				Files.Rename(NameList.Name, Temp, res);
				ArcF := Files.New(NameList.Name);
				Files.Set(R, ArcF, 0);
				TmpF := Files.Old(Temp);
				Files.Set(Rt, TmpF, 0);
				WHILE DeleteList # NIL DO
					CopyFrom(Rt, R, DeleteList.start-Files.Pos(Rt));
					Files.Set(Rt, TmpF, DeleteList.end);
					DeleteList := DeleteList.next
				END;
				CopyTo(Rt, R);
				Files.Close(TmpF);
				Files.Delete(Temp, res);
				Files.Register(ArcF)
			END;
			IF changed & (cmdSource=Menu) THEN Directory END
		END Delete;
		PROCEDURE Extract*;
			VAR
				NameList: List;
				ArcF, AddF: Files.File;
				R: Files.Rider;
				h: Header;
				pos: LONGINT;
				res: INTEGER;
				err: BOOLEAN;
		BEGIN
			GetArgs(NameList);
			IF (NameList = NIL) OR (NameList.next = NIL) THEN
				RETURN
			END;
			ArcF := OpenArchive(NameList, TRUE);
			IF ArcF = NIL THEN
				RETURN
			END;
			WriteString("Compress.Extract ");
			WriteString(NameList.Name);
			WriteLn;
			Files.Set(R, ArcF, 0);
			ReadHeader(R, h, err);
			WHILE (h.Name # EOFName) & (NameList.next # NIL) & ~err DO
				pos := Files.Pos(R);
				IF Search(NameList, h.Name) # NIL THEN
					WriteString("    ");
					WriteString(h.Name);
					AddF := Files.Old(h.Name);
					IF AddF # NIL THEN
						WriteString(" overwriting");
						Files.Close(AddF);
						Files.Delete(h.Name, res)
					END;
					WriteLn;
					AddF := Files.New(h.Name);
					CopyFromArc(R, AddF, h.length);
					Files.Register(AddF);
					Remove(NameList, h.Name)
				END;
				Files.Set(R, ArcF, pos+h.length);
				ReadHeader(R, h, err)
			END;
			IF err THEN
				WriteString(err1);
				WriteLn
			END;
			IF NameList.next # NIL THEN
				NameList := NameList.next;
				WHILE NameList # NIL DO
					WriteString(NameList.Name);
					WriteString(err2);
					WriteLn;
					NameList := NameList.next
				END
			END;
			Files.Close(ArcF)
		END Extract;
		PROCEDURE ExtractAll*;
			VAR
				NameList: List;
				ArcF, AddF: Files.File;
				R: Files.Rider;
				h: Header;
				pos: LONGINT;
				res: INTEGER;
				err: BOOLEAN;
		BEGIN
			GetArgs(NameList);
			IF NameList = NIL THEN
				RETURN
			END;
			ArcF := OpenArchive(NameList, TRUE);
			IF ArcF = NIL THEN
				RETURN
			END;
			WriteString("Compress.ExtractAll ");
			WriteString(NameList.Name);
			WriteLn;
			Files.Set(R, ArcF, 0);
			ReadHeader(R, h, err);
			WHILE (h.Name # EOFName) &  ~err DO
				WriteString("    ");
				WriteString(h.Name);
				pos := Files.Pos(R);
				AddF := Files.Old(h.Name);
				IF AddF # NIL THEN
					WriteString(" overwriting");
					Files.Close(AddF);
					Files.Delete(h.Name, res)
				END;
				WriteLn;
				AddF := Files.New(h.Name);
				CopyFromArc(R, AddF, h.length);
				Files.Register(AddF);
				Files.Set(R, ArcF, pos+h.length);
				ReadHeader(R, h, err)
			END;
			IF err THEN
				WriteString(err1);
				WriteLn
			END;
			Files.Close(ArcF)
		END ExtractAll;
		PROCEDURE Open*;
			VAR
				NameList: List;
				ArcF, AddF: Files.File;
				R: Files.Rider;
				h: Header;
				pos: LONGINT;
				res, x, y: INTEGER;
				err: BOOLEAN;
				t: Texts.Text;
				V: MenuViewers.Viewer;
		BEGIN
			GetArgs(NameList);
			IF NameList = NIL THEN
				RETURN
			ELSIF NameList.next = NIL THEN
				RETURN
			END;
			ArcF := OpenArchive(NameList, TRUE);
			IF ArcF = NIL THEN
				RETURN
			END;
			AddF := NIL;
			Files.Set(R, ArcF, 0);
			ReadHeader(R, h, err);
			WHILE (h.Name # EOFName) &  ~err & (AddF = NIL) DO
				pos := Files.Pos(R);
				IF h.Name = NameList.next.Name THEN
					AddF := Files.New(Temp);
					CopyFromArc(R, AddF, h.length);
					Files.Register(AddF)
				ELSE
					Files.Set(R, ArcF, pos+h.length);
					ReadHeader(R, h, err)
				END
			END;
			IF err THEN
				WriteString(err1);
				WriteLn
			END;
			Files.Close(ArcF);
			IF AddF # NIL THEN
				NEW(t);
				t := TextFrames.Text(Temp);
				Oberon.AllocateUserViewer(Oberon.Mouse.X, x, y);
				V := MenuViewers.New(TextFrames.NewMenu(h.Name, EditMenu),
						TextFrames.NewText(t, 0), TextFrames.menuH, x, y);
				V.dsc.next.handle := TextFrames.Handle;
				Files.Delete(Temp, res)
			ELSE
				WriteString(NameList.next.Name);
				WriteString(err2);
				WriteLn
			END
		END Open;
		PROCEDURE Compile*;
			VAR
				NameList: List;
				ArcF, AddF: Files.File;
				R: Files.Rider;
				h: Header;
				pos: LONGINT;
				res, x, y: INTEGER;
				err: BOOLEAN;
				t: Texts.Text;
				V: MenuViewers.Viewer;
				T: Texts.Text; par: Oberon.ParList; cmd: ARRAY 32 OF CHAR;
		BEGIN
			COPY("Compiler.Compile", cmd);
			NEW(par); par.pos := 0; par.text := TextFrames.Text(""); par.frame := Oberon.Par.frame; par.vwr:= Oberon.Par.vwr;
			GetArgs(NameList);
			IF sym THEN WriteString("Compiler.Compile/s"); WriteLn; END;
			IF NameList = NIL THEN
				RETURN
			ELSIF NameList.next = NIL THEN
				RETURN
			END;
			ArcF := OpenArchive(NameList, TRUE);
			IF ArcF = NIL THEN
				RETURN
			END;
			AddF := NIL;
			Files.Set(R, ArcF, 0);
			ReadHeader(R, h, err);
			WHILE (h.Name # EOFName) & (NameList.next # NIL) & ~err DO
				pos := Files.Pos(R);
				IF Search(NameList, h.Name) # NIL THEN
					AddF := Files.New(Temp);
					CopyFromArc(R, AddF, h.length);
					Files.Register(AddF);
					Texts.WriteString(W, Temp); 
					IF sym THEN Texts.WriteString(W, "/s") END;
					Texts.WriteString(W, " ~");
					Texts.Delete(par.text, 0, par.text.len); Texts.Append(par.text, W.buf);
					COPY("Compiler.Compile", cmd); Oberon.Call(cmd, par, FALSE, res);
					Remove(NameList, h.Name)
				END;
				Files.Set(R, ArcF, pos+h.length);
				ReadHeader(R, h, err)
			END;
			IF err THEN
				WriteString(err1);
				WriteLn
			END;
			Files.Close(ArcF);
		END Compile;
	PROCEDURE CompileS*;
	BEGIN
		sym := TRUE; Compile; sym := FALSE;
	END CompileS;
BEGIN
	Texts.OpenWriter(W);
	T := Oberon.Log;
	Texts.WriteString(W, "Compress, EJZ 30.11.94");
	Texts.WriteLn(W);
	Texts.Append(Oberon.Log, W.buf);
	NEW(Tree)
END Compress.