home *** CD-ROM | disk | FTP | other *** search
/ Amiga MA Magazine 1998 #6 / amigamamagazinepolishissue1998.iso / coders / jËzyki_programowania / oberon / system / asciicoder.mod (.txt) < prev    next >
Oberon Text  |  2012-04-20  |  11KB  |  213 lines
  1. Syntax10.Scn.Fnt
  2. Syntax10i.Scn.Fnt
  3. Syntax10b.Scn.Fnt
  4. MODULE AsciiCoder; (* Wolfgang Weck 14 Dec 93, compression due to Stefan Ludwig *)
  5.     IMPORT
  6.         Oberon, MenuViewers, Viewers, TextFrames, Texts, Files;
  7.     CONST
  8.         Base = 48; StopBase = 35;
  9.         N = 16384;
  10.         DefaultMenu = "System.Close  System.Copy  System.Grow  Edit.Search  Edit.Replace  Edit.Parcs  Edit.Store ";
  11.     TYPE
  12.         NameList = POINTER TO NameDesc;
  13.         NameDesc = RECORD
  14.             next: NameList;
  15.             name: POINTER TO ARRAY 64 OF CHAR
  16.         END;
  17.         w: Texts.Writer;
  18.         table: ARRAY N OF CHAR;    (* hash table for compression *)
  19.     PROCEDURE Compress*(src, dest: Files.File);    (* due to Stefan Ludwig *)
  20.         VAR hash, byte, bit, i: LONGINT; ch: CHAR; from, to: Files.Rider;
  21.     BEGIN
  22.         i := 0; REPEAT table[i] := 0X; INC(i) UNTIL i = N;
  23.         Files.Set(from, src, 0); Files.Set(to, dest, 0);
  24.         i := Files.Length(src); Files.WriteNum(to, i);
  25.         hash := 0; bit := 0; byte := 0;
  26.         REPEAT
  27.             Files.Read(from, ch);
  28.             IF table[hash] = ch THEN    (* 0 bit for correct prediction *)
  29.                 INC(bit); IF bit = 8 THEN Files.Write(to, CHR(byte)); byte := 0; bit := 0 END
  30.             ELSE    (* Incorrect prediction -> 1'xxxx'xxxx bits where x = ch[0..7] *)
  31.                 table[hash] := ch; INC(byte, ASH(1, bit)); INC(bit);
  32.                 IF bit = 8 THEN Files.Write(to, CHR(byte)); Files.Write(to, ch);  byte := 0; bit := 0
  33.                 ELSE Files.Write(to, CHR(byte+ASH(ORD(ch), bit) MOD 256)); byte := ASH(ORD(ch), bit) DIV 256
  34.                 END
  35.             END;
  36.             DEC(i); hash := (16*hash+ORD(ch)) MOD N    (* hash value *)
  37.         UNTIL i = 0;
  38.         IF bit # 0 THEN Files.Write(to, CHR(byte)) END    (* write last byte *)
  39.     END Compress;
  40.     PROCEDURE Expand*(src, dest: Files.File);    (* due to Stefan Ludwig *)
  41.         VAR hash, val, byte, bit, i: LONGINT; ch: CHAR; from, to: Files.Rider;
  42.     BEGIN
  43.         i := 0; REPEAT table[i] := 0X; INC(i) UNTIL i = N;
  44.         Files.Set(from, src, 0); Files.Set(to, dest, 0);
  45.         Files.ReadNum(from, i); Files.Read(from, ch); val := ORD(ch); bit := 0; hash := 0;
  46.         REPEAT
  47.             INC(bit);
  48.             IF ODD(val) THEN    (* Incorrect prediction -> 1'xxxx'xxxx *)
  49.                 Files.Read(from, ch);
  50.                 IF bit = 8 THEN byte := ORD(ch)
  51.                 ELSE byte := val DIV 2 + ASH(ORD(ch), 8-bit) MOD 256; val := ASH(ORD(ch), -bit)
  52.                 END;
  53.                 table[hash] := CHR(byte)
  54.             ELSE byte := ORD(table[hash]); val := val DIV 2    (* correct prediction *)
  55.             END;
  56.             hash := (16*hash+byte) MOD N; Files.Write(to, CHR(byte)); DEC(i);
  57.             IF bit = 8 THEN Files.Read(from, ch); val := ORD(ch); bit := 0 END
  58.         UNTIL i = 0
  59.     END Expand;
  60.     PROCEDURE Code*(from: Files.File; to: Texts.Text);
  61.         VAR byte, rest, div, factor, packs: INTEGER; ch: CHAR; r: Files.Rider;
  62.     BEGIN Files.Set(r, from, 0); Files.Read(r, ch); byte := ORD(ch); rest := 0; div := 64; factor  := 1; packs := 0;
  63.         WHILE ~r.eof DO Texts.Write(w, CHR(Base + rest + (byte MOD div) * factor)); rest := byte DIV div;
  64.             IF div = 4 THEN Texts.Write(w, CHR(Base + rest));
  65.                 rest := 0; div := 64; factor  := 1; INC(packs);
  66.                 IF packs = 19 THEN Texts.WriteLn(w); packs := 0 END
  67.             ELSE factor := factor * 4; div := div DIV 4
  68.             END;
  69.             Files.Read(r, ch); byte := ORD(ch)
  70.         END;
  71.         IF div = 64 THEN Texts.Write(w, CHR(StopBase))
  72.         ELSIF div = 16 THEN Texts.Write(w, CHR(Base + rest)); Texts.Write(w, CHR(StopBase + 1))
  73.         ELSIF div = 4 THEN Texts.Write(w, CHR(Base + rest)); Texts.Write(w, CHR(StopBase + 2))
  74.         END;
  75.         Texts.WriteLn(w); Texts.Append(to, w.buf)
  76.     END Code;
  77.     PROCEDURE Decode*(from: Texts.Text; VAR pos: LONGINT; to: Files.File; VAR ok: BOOLEAN);
  78.         VAR rest, div, factor, byte: INTEGER; ch: CHAR; r: Texts.Reader; w: Files.Rider;
  79.     BEGIN Texts.OpenReader(r, from, pos); Files.Set(w, to, 0); factor := 1; div := 256;
  80.         REPEAT Texts.Read(r, ch) UNTIL (ch > " ") OR r.eot;
  81.         WHILE ~r.eot & (ch >= CHR(Base)) & (ch < CHR(Base + 64)) DO byte := ORD(ch) - Base;
  82.             IF factor # 1 THEN Files.Write(w, CHR(rest + (byte MOD div) * factor));
  83.                 rest := byte DIV div; div := div * 4; factor := factor DIV 4
  84.             ELSE rest := byte; div := 4; factor := 64
  85.             END;
  86.             REPEAT Texts.Read(r, ch) UNTIL (ch > " ") OR r.eot
  87.         END;
  88.         byte := ORD(ch) - StopBase;
  89.         ok := (byte = 0) & (div = 256) OR (byte = 1) & (div = 16) OR (byte = 2) & (div = 64) & (rest = 0);
  90.         pos := Texts.Pos(r)
  91.     END Decode;
  92.     PROCEDURE OpenViewer(name: ARRAY OF CHAR; text: Texts.Text);
  93.         VAR x, y: INTEGER; v: Viewers.Viewer; mf, cf: TextFrames.Frame;
  94.     BEGIN Oberon.AllocateUserViewer(Oberon.Par.vwr.X, x, y);
  95.         mf := TextFrames.NewMenu(name, DefaultMenu);
  96.         IF Files.Old("Edit.Menu.Text") # NIL THEN Texts.Open(mf.text, "Edit.Menu.Text");
  97.             Texts.WriteString(w, name); Texts.WriteString(w, " | "); Texts.Insert(mf.text, 0, w.buf)
  98.         END;
  99.         cf := TextFrames.NewText(text, 0);
  100.         v := MenuViewers.New(mf, cf, TextFrames.menuH, x, y)
  101.     END OpenViewer;
  102.     PROCEDURE ReadFileNames(t: Texts.Text; beg, end: LONGINT; VAR names: NameList; VAR pos: LONGINT);
  103.         VAR last, n: NameList; s: Texts.Scanner;
  104.     BEGIN NEW(names); last := names; Texts.OpenScanner(s, t, beg); pos := beg; Texts.Scan(s);
  105.         WHILE (pos < end) & ((s.class = Texts.String) OR (s.class = Texts.Name)) DO NEW(n); last.next := n; last := n;
  106.             NEW(n.name); COPY(s.s, n.name^);
  107.             pos := Texts.Pos(s); Texts.Scan(s)
  108.         END;
  109.         last.next := NIL; names := names.next; pos := Texts.Pos(s)
  110.     END ReadFileNames;
  111.     PROCEDURE CodeFiles*;
  112.         VAR pos, beg, end, time: LONGINT; compress: BOOLEAN; names, n: NameList;
  113.             f, f1: Files.File; text: Texts.Text; s: Texts.Scanner; 
  114.     BEGIN pos := Oberon.Par.pos; compress := FALSE;
  115.         Texts.OpenScanner(s, Oberon.Par.text, pos); Texts.Scan(s);
  116.         IF (s.line = 0) & (s.class = Texts.Char)  & (s.c = "%") THEN compress := TRUE; pos := Texts.Pos(s); Texts.Scan(s) END;
  117.         IF (s.line = 0) & (s.class = Texts.Char)  & (s.c = "^") THEN Oberon.GetSelection(text, beg, end, time);
  118.             IF time >= 0 THEN ReadFileNames(text, beg, end, names, time) ELSE names := NIL END
  119.         ELSE ReadFileNames(Oberon.Par.text, pos, Oberon.Par.text.len, names, time)
  120.         END;
  121.         IF names # NIL THEN n := names; text := TextFrames.Text("");
  122.             Texts.WriteString(w, "AsciiCoder.CodeFiles"); Texts.WriteLn(w);
  123.             REPEAT f := Files.Old(n.name^); Texts.WriteString(w, n.name^);
  124.                 IF f = NIL THEN Texts.WriteString(w, " not found"); n.name := NIL
  125.                 ELSE Texts.WriteString(w, " coding"); Texts.Append(Oberon.Log, w.buf);
  126.                     IF compress THEN f1 := Files.New(""); Compress(f, f1); f := f1 END;
  127.                     Code(f, text)
  128.                 END;
  129.                 Texts.WriteLn(w); Texts.Append(Oberon.Log, w.buf); n := n.next
  130.             UNTIL n = NIL;
  131.             Texts.WriteString(w,"AsciiCoder.DecodeFiles ");
  132.             IF compress THEN Texts.WriteString(w, "% ") END;
  133.             REPEAT
  134.                 IF names.name # NIL THEN Texts.WriteString(w, names.name^); Texts.Write(w, " ") END;
  135.                 names := names.next
  136.             UNTIL names = NIL;
  137.             Texts.Write(w, "~"); Texts.WriteLn(w); Texts.WriteLn(w); Texts.Insert(text, 0, w.buf);
  138.             Texts.WriteInt(w, text.len, 0); Texts.WriteString(w, " characters"); Texts.WriteLn(w);
  139.             Texts.Append(Oberon.Log, w.buf);
  140.             OpenViewer("AsciiCoder.CodeFiles", text)
  141.         END
  142.     END CodeFiles;
  143.     PROCEDURE DecodeFiles*;
  144.         VAR pos, beg, end, time: LONGINT; i, res: INTEGER; ch: CHAR; ok, compress: BOOLEAN;
  145.             f, f1: Files.File; text: Texts.Text; s: Texts.Scanner; names: NameList; bakname: ARRAY 256 OF CHAR;
  146.     BEGIN text := Oberon.Par.text; pos := Oberon.Par.pos; compress := FALSE;
  147.         Texts.OpenScanner(s, text, pos); Texts.Scan(s);
  148.         IF (s.line = 0) & (s.class = Texts.Char)  & (s.c = "%") THEN compress := TRUE; pos := Texts.Pos(s); Texts.Scan(s) END;
  149.         IF (s.line = 0) & (s.class = Texts.Char)  & (s.c = "@") THEN Oberon.GetSelection(text, beg, end, time);
  150.             IF time >= 0 THEN ReadFileNames(text, beg, end, names, pos) ELSE names := NIL END
  151.         ELSE ReadFileNames(text, pos, text.len, names, pos)
  152.         END;
  153.         Texts.WriteString(w, "AsciiCoder.DecodeFiles"); Texts.WriteLn(w); ok := TRUE;
  154.         WHILE (names # NIL) & ok DO f := Files.New(names.name^);
  155.             Texts.WriteString(w, names.name^); Texts.WriteString(w, " decoding"); Texts.Append(Oberon.Log, w.buf);
  156.             i := 0; ch := names.name[0];
  157.             WHILE ch # 0X DO bakname[i] := ch; INC(i); ch := names.name[i] END;
  158.             bakname[i] := "."; bakname[i + 1] := "B"; bakname[i + 2] := "a"; bakname[i + 3] := "k"; bakname[i + 4] := 0X;
  159.             Files.Rename(names.name^, bakname, res); Decode(text, pos, f, ok);
  160.             IF ok THEN
  161.                 IF compress THEN f1 := Files.New(names.name^); Expand(f, f1); f := f1 END;
  162.                 Files.Register(f)
  163.             ELSE Texts.WriteString(w, " error.")
  164.             END;
  165.             Texts.WriteLn(w); Texts.Append(Oberon.Log, w.buf); names := names.next
  166.         END
  167.     END DecodeFiles;
  168.     PROCEDURE CodeText*;
  169.         VAR beg, end, time: LONGINT; compress: BOOLEAN;
  170.             v: Viewers.Viewer; f, f1: Files.File; r: Files.Rider; t, text: Texts.Text; s: Texts.Scanner;
  171.     BEGIN compress := FALSE;
  172.         Texts.OpenScanner(s, Oberon.Par.text, Oberon.Par.pos); Texts.Scan(s);
  173.         IF (s.line = 0) & (s.class = Texts.Char)  & (s.c = "%") THEN compress := TRUE; Texts.Scan(s) END;
  174.         IF (s.line = 0) & (s.class = Texts.Char) THEN t := NIL;
  175.             IF s.c = "*" THEN v := Oberon.MarkedViewer();
  176.                 IF (v IS MenuViewers.Viewer) & (v.dsc.next IS TextFrames.Frame) THEN
  177.                     t := v.dsc.next(TextFrames.Frame).text
  178.                 END
  179.             ELSIF s.c = "@" THEN Oberon.GetSelection(text, beg, end, time);
  180.                 IF time >= 0 THEN t := TextFrames.Text(""); Texts.Save(text, beg, end, w.buf); Texts.Append(t, w.buf) END
  181.             END;
  182.             IF t # NIL THEN f := Files.New(""); Files.Set(r, f, 0); Files.Write(r, 0F0X); Files.Write(r, 01X); Texts.Store(r, t);
  183.                 text := TextFrames.Text("");
  184.                 Texts.WriteString(w, "AsciiCoder.DecodeText");
  185.                 IF compress THEN Texts.WriteString(w, " %") END;
  186.                 Texts.WriteLn(w); Texts.WriteLn(w); Texts.Append(text, w.buf);
  187.                 IF compress THEN f1 := Files.New(""); Compress(f, f1); f := f1 END;
  188.                 Code(f, text); OpenViewer("AsciiCoder.CodeText", text);
  189.                 Texts.WriteString(w, "AsciiCoder.CodeText "); Texts.WriteInt(w, text.len, 0);
  190.                 Texts.WriteString(w, " characters"); Texts.WriteLn(w); Texts.Append(Oberon.Log, w.buf)
  191.             END
  192.         END
  193.     END CodeText;
  194.     PROCEDURE DecodeText*;
  195.         VAR pos, beg, end, time: LONGINT; ok, compress: BOOLEAN;
  196.             f, f1: Files.File; r: Files.Rider; text: Texts.Text; s: Texts.Scanner;
  197.     BEGIN compress := FALSE; pos := Oberon.Par.pos; f := Files.New("");
  198.         Texts.OpenScanner(s, Oberon.Par.text, Oberon.Par.pos); Texts.Scan(s);
  199.         IF (s.line = 0) & (s.class = Texts.Char)  & (s.c = "%") THEN compress := TRUE; pos := Texts.Pos(s); Texts.Scan(s) END;
  200.         IF (s.line = 0) & (s.class = Texts.Char)  & (s.c = "@") THEN Oberon.GetSelection(text, beg, end, time);
  201.             IF time >= 0 THEN Decode(text, beg, f, ok) ELSE ok := FALSE END
  202.         ELSE Decode(Oberon.Par.text, pos, f, ok)
  203.         END;
  204.         IF ok THEN
  205.             IF compress THEN f1 := Files.New(""); Expand(f, f1); f := f1 END;
  206.             text := TextFrames.Text(""); Files.Set(r, f, 2); Texts.Load(r, text);
  207.             OpenViewer("AsciiCoder.DecodeText", text)
  208.         ELSE Texts.WriteString(w, "AsciiCoder.DecodeText error."); Texts.WriteLn(w); Texts.Append(Oberon.Log, w.buf)
  209.         END
  210.     END DecodeText;
  211. BEGIN Texts.OpenWriter(w)
  212. END AsciiCoder.
  213.