Obx/Mod/Ratcalc.odc

MODULE ObxRatCalc;
(**
	project	= "BlackBox"
	organization	= "www.oberon.ch"
	contributors	= "Oberon microsystems"
	version	= "System/Rsrc/About"
	copyright	= "System/Rsrc/About"
	license	= "Docu/BB-License"
	changes	= "
	- YYYYMMDD, nn, ...
	"
	issues	= "
	- ...
	"

**)

	IMPORT Stores, Models, Dialog, TextModels, TextControllers, TextMappers, Integers;

	CONST
		(* scanner classes *)
		stop = 0; int = 1; openPar = 2; closePar = 3; powOp = 4; mulOp = 5; addOp = 6;
		approximationLength = 40;

	TYPE
		Scanner = RECORD
			r: TextModels.Reader;
			nextCh: CHAR;
			end, level: INTEGER;
			pos: INTEGER;
			class: INTEGER;
			num, den: Integers.Integer;
			op: CHAR;
			error: BOOLEAN
		END;

		Expression = POINTER TO RECORD
			op: CHAR;
			sub1, sub2: Expression;
			int: Integers.Integer
		END;

	VAR zero, one, ten, hundred, maxExponent, minusOne: Integers.Integer;


	(* scanning *)

	PROCEDURE ReadInteger (r: TextModels.Reader; OUT nextCh: CHAR; OUT num, den: Integers.Integer);
		VAR i, j, l1, l2, beg: INTEGER; ch: CHAR; buf: POINTER TO ARRAY OF CHAR;
	BEGIN
		beg := r.Pos() - 1; l1 := 0; l2 := 0;
		REPEAT INC(l1); r.ReadChar(ch) UNTIL r.eot OR (ch < "0") OR (ch > "9");
		IF ch = "." THEN
			r.ReadChar(ch);
			WHILE (ch >= "0") & (ch <= "9") DO INC(l2); r.ReadChar(ch) END
		END;
		NEW(buf, l1 + l2 + 1);
		i := 0; r.SetPos(beg);
		REPEAT r.ReadChar(buf[i]); INC(i) UNTIL i = l1;
		IF l2 # 0 THEN
			j := l2; r.ReadChar(ch);
			REPEAT r.ReadChar(buf[i]); INC(i); DEC(j) UNTIL j = 0
		END;
		buf[i] := 0X;
		Integers.ConvertFromString(buf^, num);
		IF l2 # 0 THEN
			buf[0] := "1"; i := 1;
			REPEAT buf[i] := "0"; INC(i) UNTIL i = l2 + 1;
			buf[i] := 0X;
			Integers.ConvertFromString(buf^, den)
		ELSE den := NIL
		END;
		r.ReadChar(nextCh)
	END ReadInteger;

	PROCEDURE (VAR s: Scanner) Read, NEW;
		VAR ch: CHAR;
	BEGIN
		IF ~s.error THEN
			ch := s.nextCh;
			IF s.r.eot THEN s.pos := s.r.Pos() ELSE s.pos := s.r.Pos() - 1 END;
			WHILE ~s.r.eot & (s.r.Pos() <= s.end) & (ch <= " ") DO s.r.ReadChar(ch) END;
			IF ~s.r.eot & (s.r.Pos() <= s.end) THEN
				IF (ch >= "0") & (ch <= "9") THEN s.class := int; ReadInteger(s.r, ch, s.num, s.den)
				ELSIF (ch = "+") OR (ch = "-") THEN s.class := addOp; s.op := ch; s.r.ReadChar(ch)
				ELSIF (ch = "*") OR (ch = "/") THEN s.class := mulOp; s.op := ch; s.r.ReadChar(ch)
				ELSIF ch = "^" THEN s.class := powOp; s.op := ch; s.r.ReadChar(ch)
				ELSIF ch = "(" THEN s.class := openPar; INC(s.level); s.r.ReadChar(ch)
				ELSIF ch = ")" THEN s.class := closePar; DEC(s.level); s.r.ReadChar(ch)
				ELSE s.error := TRUE
				END
			ELSE s.class := stop
			END;
			s.nextCh := ch
		ELSE s.class := stop
		END
	END Read;

	PROCEDURE (VAR s: Scanner) ConnectTo (t: TextModels.Model; beg, end: INTEGER), NEW;
		VAR ch: CHAR;
	BEGIN
		s.r := t.NewReader(NIL); s.r.SetPos(beg); s.r.ReadChar(ch);
		WHILE ~s.r.eot & (beg < end) & (ch <= " ") DO s.r.ReadChar(ch); INC(beg) END;
		s.nextCh := ch; s.pos := beg; s.end := end;
		s.level := 0; s.error := FALSE
	END ConnectTo;


	(* parsing *)

	PROCEDURE^ ReadExpression (VAR s: Scanner; OUT exp: Expression);

	PROCEDURE ReadFactor (VAR s: Scanner; OUT exp: Expression);
		VAR e: Expression;
	BEGIN
		IF s.class = openPar THEN
			s.Read;
			ReadExpression(s, exp);
			s.error := s.error OR (s.class # closePar); s.Read
		ELSIF s.class = int THEN
			IF s.den = NIL THEN
				NEW(exp); exp.op := "i"; exp.int := s.num
			ELSE
				NEW(exp); exp.op := "/";
				NEW(e); e.op := "i"; e.int := s.num; exp.sub1 := e;
				NEW(e); e.op := "i"; e.int := s.den; exp.sub2 := e
			END;
			s.Read
		ELSE s.error := TRUE
		END;
		IF ~s.error & (s.class = powOp) THEN
			NEW(e); e.op := s.op; e.sub1 := exp; exp := e;
			s.Read; ReadFactor(s, e.sub2)
		END
	END ReadFactor;

	PROCEDURE ReadTerm (VAR s: Scanner; OUT exp: Expression);
		VAR e: Expression;
	BEGIN
		ReadFactor(s, exp);
		WHILE ~s.error & (s.class = mulOp) DO
			NEW(e); e.op := s.op; e.sub1 := exp; exp := e;
			s.Read; ReadFactor(s, exp.sub2)
		END
	END ReadTerm;

	PROCEDURE ReadExpression (VAR s: Scanner; OUT exp: Expression);
		VAR e: Expression;
	BEGIN
		IF (s.class = addOp) & (s.op = "-") THEN
			s.Read;
			NEW(e); e.op := "i"; e.int := zero;
			NEW(exp); exp.op := "-"; exp.sub1 := e;
			ReadTerm(s, exp.sub2)
		ELSE ReadTerm(s, exp)
		END;
		WHILE ~s.error & (s.class = addOp) DO
			NEW(e); e.op := s.op; e.sub1 := exp; exp := e;
			s.Read; ReadTerm(s, exp.sub2)
		END
	END ReadExpression;


	(* evaluation *)

	PROCEDURE Normalize (VAR num, den: Integers.Integer);
		VAR g: Integers.Integer;
	BEGIN
		IF Integers.Sign(num) # 0 THEN
			g := Integers.GCD(num, den);
			num := Integers.Quotient(num, g); den := Integers.Quotient(den, g);
			IF Integers.Sign(den) < 0 THEN
				num := Integers.Product(num, minusOne); den := Integers.Abs(den)
			END
		ELSE den := one
		END
	END Normalize;

	PROCEDURE Evaluate (exp: Expression; OUT num, den: Integers.Integer; VAR error: INTEGER);
		VAR exponent: INTEGER; op: CHAR; n1, d1, n2, d2, g, h: Integers.Integer;
	BEGIN
		error := 0; op := exp.op;
		IF op = "i" THEN num := exp.int; den := one
		ELSE
			Evaluate(exp.sub1, n1, d1, error);
			IF error = 0 THEN Evaluate(exp.sub2, n2, d2, error);
				IF error = 0 THEN
					IF (op = "+") OR (op = "-") THEN
						g := Integers.GCD(d1, d2); h := Integers.Quotient(d2, g);
						IF op = "+" THEN
							num := Integers.Sum(
								Integers.Product(n1, h), Integers.Product(n2, Integers.Quotient(d1, g)))
						ELSE
							num := Integers.Difference(
								Integers.Product(n1, h), Integers.Product(n2, Integers.Quotient(d1, g)))
						END;
						den := Integers.Product(d1, h);
						Normalize(num, den)
					ELSIF op = "*" THEN
						num := Integers.Product(n1, n2); den := Integers.Product(d1, d2);
						Normalize(num, den)
					ELSIF op = "/" THEN
						IF Integers.Sign(n2) # 0 THEN
							num := Integers.Product(n1, d2); den := Integers.Product(d1, n2);
							Normalize(num, den)
						ELSE error := 1
						END
					ELSIF op = "^" THEN
						IF Integers.Sign(n1) = 0 THEN num := n1; den := d1
						ELSE
							IF Integers.Compare(d2, one) = 0 THEN
								IF Integers.Sign(n2) = 0 THEN num := one; den := one
								ELSE
									IF Integers.Sign(n2) < 0 THEN
										g := n1; n1 := d1; d1 := g; n2 := Integers.Abs(n2)
									END;
									IF Integers.Compare(n2, maxExponent) <= 0 THEN
										exponent := SHORT(Integers.Short(n2));
										num := Integers.Power(n1, exponent); den := Integers.Power(d1, exponent);
										Normalize(num, den)
									ELSE error := 3
									END
								END
							ELSE error := 2
							END
						END
					ELSE HALT(99)
					END
				END
			END
		END
	END Evaluate;


	(* output *)

	PROCEDURE WriteInteger (w: TextModels.Writer; x: Integers.Integer);
		VAR i: INTEGER;
	BEGIN
		IF Integers.Sign(x) # 0 THEN
			IF Integers.Sign(x) < 0 THEN w.WriteChar("-") END;
			i := Integers.Digits10Of(x);
			REPEAT DEC(i); w.WriteChar(Integers.ThisDigit10(x, i)) UNTIL i = 0
		ELSE w.WriteChar("0")
		END
	END WriteInteger;

	PROCEDURE Replace (t: TextModels.Model; VAR beg, end: INTEGER; n, d: Integers.Integer;
									a: TextModels.Attributes);
		VAR s: Stores.Operation; w: TextMappers.Formatter;
	BEGIN
		Models.BeginScript(t, "computation", s);
		t.Delete(beg, end);
		w.ConnectTo(t); w.SetPos(beg); w.rider.SetAttr(a);
		WriteInteger(w.rider, n);
		IF (Integers.Sign(n) # 0) & (Integers.Compare(d, one) # 0) THEN
			w.WriteString(" / "); WriteInteger(w.rider, d)
		END;
		Models.EndScript(t, s);
		end := w.Pos()
	END Replace;

	PROCEDURE ReplaceReal (t: TextModels.Model; VAR beg, end: INTEGER; n, d: Integers.Integer;
											a: TextModels.Attributes);
		VAR i, k, e: INTEGER; q, r: Integers.Integer; s: Stores.Operation; w: TextMappers.Formatter;
	BEGIN
		Models.BeginScript(t, "computation", s);
		t.Delete(beg, end);
		w.ConnectTo(t); w.SetPos(beg); w.rider.SetAttr(a);
		IF Integers.Sign(n) < 0 THEN w.WriteChar("-"); n := Integers.Abs(n) END;
		Integers.QuoRem(n, d, q, r);
		k := Integers.Digits10Of(q);
		IF k > approximationLength THEN
			DEC(k); e := k;
			w.WriteChar(Integers.ThisDigit10(q, k)); w.WriteChar(".");
			i := 1;
			REPEAT DEC(k); w.WriteChar(Integers.ThisDigit10(q, k)); INC(i) UNTIL i = approximationLength;
			w.WriteString("...*10^"); w.WriteInt(e)
		ELSE
			e := 0;
			IF (k = 0) & (Integers.Sign(r) # 0) & (Integers.Compare(Integers.Quotient(d, r), hundred) > 0)
			THEN
				REPEAT
					Integers.QuoRem(Integers.Product(ten, r), d, q, r); INC(e)
				UNTIL Integers.Sign(q) # 0
			ELSIF k = 0 THEN k := 1
			END;
			WriteInteger(w.rider, q);
			IF Integers.Sign(r) # 0 THEN
				w.WriteChar(".");
				REPEAT
					Integers.QuoRem(Integers.Product(ten, r), d, q, r);
					WriteInteger(w.rider, q); INC(k)
				UNTIL (Integers.Sign(r) = 0) OR (k = approximationLength);
				IF Integers.Sign(r) # 0 THEN w.WriteString("...") END
			END;
			IF e # 0 THEN w.WriteString("*10^-"); w.WriteInt(e) END
		END;
		Models.EndScript(t, s);
		end := w.Pos()
	END ReplaceReal;


	(* commands *)

	PROCEDURE Compute (approx: BOOLEAN);
		VAR beg, end, error: INTEGER; exp: Expression; s: Scanner;
			attr: TextModels.Attributes; c: TextControllers.Controller; num, den: Integers.Integer;
	BEGIN
		c := TextControllers.Focus();
		IF (c # NIL) & c.HasSelection() THEN
			c.GetSelection(beg, end); s.ConnectTo(c.text, beg, end); attr := s.r.attr; beg := s.pos;
			s.Read; ReadExpression(s, exp); end := s.pos;
			IF ~s.error & (s.class = stop) THEN
				Evaluate(exp, num, den, error);
				IF error = 0 THEN
					IF approx THEN ReplaceReal(c.text, beg, end, num, den, attr)
					ELSE Replace(c.text, beg, end, num, den, attr)
					END;
					c.SetSelection(beg, end)
				ELSIF error = 1 THEN Dialog.ShowMsg("division by zero.")
				ELSIF error = 2 THEN Dialog.ShowMsg("non-integer exponent.")
				ELSIF error = 3 THEN Dialog.ShowMsg("exponent too large.")
				ELSE HALT(99)
				END
			ELSE
				Dialog.ShowMsg("syntax error.");
				c.SetCaret(s.pos)
			END
		END
	END Compute;

	PROCEDURE Simplify*;
	BEGIN
		Compute(FALSE)
	END Simplify;

	PROCEDURE Approximate*;
	BEGIN
		Compute(TRUE)
	END Approximate;


BEGIN
	zero := Integers.Long(0); one := Integers.Long(1); ten := Integers.Long(10);
	hundred := Integers.Long(100); maxExponent := Integers.Long(1000000);
	minusOne := Integers.Long(-1)
END ObxRatCalc.