Obx/Mod/Orders.odc

MODULE ObxOrders;
(**
	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
		Files, Dialog, Fonts, Stores, Views,
		TextModels, TextViews, TextMappers, TextRulers, StdCmds, StdStamps;

	CONST
		(* values for card field of interactor *)
		amex = 0; master = 1; visa = 2;
		(* prices in 1/100 Swiss Francs *)
		ofwinfullVal = 45000; ofmacfullVal = 45000; ofwineduVal = 15000; ofmaceduVal = 15000;
		odfVal = 5000; vatVal = 65;
		type = "dat";	(* file type *)

	TYPE
		Interactor* = RECORD
			name*, company*, adr1*, adr2*, adr3*, email*: ARRAY 128 OF CHAR;
			phone*, fax*: ARRAY 32 OF CHAR;
			ofwinfull*, ofmacfull*, ofwinedu*, ofmacedu*, odf*: INTEGER;
			card*: INTEGER;
			cardno*: ARRAY 24 OF CHAR;
			vat*: BOOLEAN
		END;

		Element = POINTER TO RECORD
			prev, next: Element;
			data: Interactor
		END;

	VAR
		par*: Interactor;
		root, cur: Element;	(* header and current element of doubly-linked ring *)
		name: Files.Name;
		loc: Files.Locator;

	PROCEDURE ReadElem (VAR rd: Stores.Reader; e: Element);
	BEGIN
		rd.ReadString(e.data.name);rd.ReadString(e.data.company);
		rd.ReadString(e.data.adr1); rd.ReadString(e.data.adr2); rd.ReadString(e.data.adr3);
		rd.ReadString(e.data.email);
		rd.ReadString(e.data.phone); rd.ReadString(e.data.fax);
		rd.ReadString(e.data.cardno);
		rd.ReadInt(e.data.ofwinfull); rd.ReadInt(e.data.ofmacfull);
		rd.ReadInt(e.data.ofwinedu); rd.ReadInt(e.data.ofmacedu);
		rd.ReadInt(e.data.odf);
		rd.ReadInt(e.data.card);
		rd.ReadBool(e.data.vat)
	END ReadElem;

	PROCEDURE WriteElem (VAR wr: Stores.Writer; e: Element);
	BEGIN
		wr.WriteString(e.data.name); wr.WriteString(e.data.company);
		wr.WriteString(e.data.adr1); wr.WriteString(e.data.adr2); wr.WriteString(e.data.adr3);
		wr.WriteString(e.data.email);
		wr.WriteString(e.data.phone); wr.WriteString(e.data.fax);
		wr.WriteString(e.data.cardno);
		wr.WriteInt(e.data.ofwinfull); wr.WriteInt(e.data.ofmacfull);
		wr.WriteInt(e.data.ofwinedu); wr.WriteInt(e.data.ofmacedu);
		wr.WriteInt(e.data.odf);
		wr.WriteInt(e.data.card);
		wr.WriteBool(e.data.vat)
	END WriteElem;

	PROCEDURE Init;
	BEGIN
		cur := root; root.next := root; root.prev := root
	END Init;

	PROCEDURE Update;
	BEGIN
		par := cur.data; Dialog.Update(par)
	END Update;

	PROCEDURE Load*;
		VAR e: Element; f: Files.File; rd: Stores.Reader; count: INTEGER;
	BEGIN
		Dialog.GetIntSpec(type, loc, name);
		IF loc # NIL THEN
			f := Files.dir.Old(loc, name, Files.shared);
			IF (f # NIL) & (f.type = type) THEN
				rd.ConnectTo(f);
				rd.ReadInt(count);
				Init;
				WHILE count # 0 DO
					NEW(e);
					IF e # NIL THEN
						e.prev := cur; e.next := cur.next; e.prev.next := e; e.next.prev := e;
						ReadElem(rd, e);
						cur := e; DEC(count)
					ELSE
						Dialog.ShowMsg("out of memory"); Dialog.Beep;
						count := 0; root.next := root; root.prev := root; cur := root
					END
				END;
				Update
			ELSE
				Dialog.ShowMsg("cannot open file"); Dialog.Beep
			END
		END
	END Load;

	PROCEDURE Save*;
		VAR e: Element; f: Files.File; wr: Stores.Writer; count, res: INTEGER;
	BEGIN
		IF (loc = NIL) OR (name = "") THEN Dialog.GetExtSpec("", "", loc, name) END;
		IF (loc # NIL) & (name # "") THEN
			f := Files.dir.New(loc, Files.dontAsk); wr.ConnectTo(f);
			e := root.next; count := 0; WHILE e # root DO INC(count); e := e.next END;	(* count elements *)
			wr.WriteInt(count);
			e := root.next; WHILE e # root DO WriteElem(wr, e); e := e.next END;	(* write elements *)
			f.Register(name, type, Files.dontAsk, res);
			Init; name := ""; loc := NIL;	(* close database *)
			Update
		END
	END Save;

	PROCEDURE Insert*;
		VAR e: Element;
	BEGIN
		NEW(e);
		IF e # NIL THEN	(* insert new record at end of database *)
			IF cur # root THEN cur.data := par END;	(* save current record, in case it was changed *)
			e.prev := root.prev; e.next := root; e.prev.next := e; e.next.prev := e;
			cur := e;
			Update
		ELSE
			Dialog.ShowMsg("out of memory"); Dialog.Beep
		END
	END Insert;

	PROCEDURE Delete*;
	BEGIN
		IF cur # root THEN
			StdCmds.CloseDialog;
			cur.next.prev := cur.prev; cur.prev.next := cur.next;
			cur := cur.prev; IF cur = root THEN cur := root.next END;
			Update
		END
	END Delete;

	PROCEDURE Next*;
	BEGIN
		IF cur.next # root THEN
			cur.data := par; cur := cur.next; Update
		END
	END Next;

	PROCEDURE Prev*;
	BEGIN
		IF cur.prev # root THEN
			cur.data := par; cur := cur.prev; Update
		END
	END Prev;

	PROCEDURE NonemptyGuard* (VAR par: Dialog.Par);
	BEGIN
		par.disabled := cur = root
	END NonemptyGuard;

	PROCEDURE NextGuard* (VAR par: Dialog.Par);
	BEGIN
		par.disabled := cur.next = root
	END NextGuard;

	PROCEDURE PrevGuard* (VAR par: Dialog.Par);
	BEGIN
		par.disabled := cur.prev = root
	END PrevGuard;

	PROCEDURE WriteLine (VAR f: TextMappers.Formatter; no, val: INTEGER; name: ARRAY OF CHAR;
										VAR total, vat: INTEGER);
	BEGIN
		IF no # 0 THEN
			val := no * val;
			f.WriteInt(no); f.WriteString(name);
			INC(total, val); INC(vat, val);
			f. WriteTab;
			f.WriteIntForm(val DIV 100, 10, 5, TextModels.digitspace, FALSE);
			f.WriteChar(".");
			f.WriteIntForm(val MOD 100, 10, 2, "0", FALSE);
			f.WriteLn
		END
	END WriteLine;

	PROCEDURE NewRuler (): TextRulers.Ruler;
		VAR r: TextRulers.Ruler;
	BEGIN
		r := TextRulers.dir.New(NIL);
(*	
		TextRulers.SetLeft(r, 30 * Ports.mm);
		TextRulers.SetRight(r, 165 * Ports.mm);
		TextRulers.AddTab(r, 130 * Ports.mm);
*)
		RETURN r
	END NewRuler;

	PROCEDURE Invoice*;
		VAR v: TextViews.View; f: TextMappers.Formatter; a: TextModels.Attributes;
			total, vat: INTEGER;
	BEGIN
		IF cur # root THEN
			v := TextViews.dir.New(TextModels.dir.New());
			f.ConnectTo(v.ThisModel());
			f.WriteView(NewRuler());
			(* create header of invoice *)
			f.WriteLn; f.WriteLn; f.WriteLn; f.WriteLn; f.WriteLn; f.WriteLn; f.WriteLn;
			f.WriteTab;
			f.WriteString("Basel, "); f.WriteView(StdStamps.New());
			f.WriteLn; f.WriteLn; f.WriteLn;
			(* write address *)
			IF par.name # "" THEN f.WriteString(par.name); f.WriteLn END;
			IF par.company # "" THEN f.WriteString(par.company); f.WriteLn END;
			IF par.adr1 # "" THEN f.WriteString(par.adr1); f.WriteLn END;
			IF par.adr2 # "" THEN f.WriteString(par.adr2); f.WriteLn END;
			IF par.adr3 # "" THEN f.WriteString(par.adr3); f.WriteLn END;
			f.WriteLn; f.WriteLn; f.WriteLn;
			(* set bold font weight *)
			a := f.rider.attr;
			f.rider.SetAttr(TextModels.NewWeight(a, Fonts.bold));
			f.WriteString("Invoice");	(* this string will appear in bold face *)
			f.rider.SetAttr(a);	(* restore default weight *)
			f.WriteLn; f.WriteLn;
			f.WriteString("Creditcard: ");
			CASE par.card OF
			| amex: f.WriteString("American Express")
			| master: f.WriteString("Euro/MasterCard")
			| visa: f.WriteString("Visa")
			END;
			f.WriteLn; f.WriteLn; f.WriteLn;
			(* write products with subtotals *)
			total := 0; vat := 0;
			WriteLine(f, par.ofwinfull, ofwinfullVal, " ofwin full", total, vat);
			WriteLine(f, par.ofmacfull, ofmacfullVal, " ofmac full", total, vat);
			WriteLine(f, par.ofwinedu, ofwineduVal, " ofwin edu", total, vat);
			WriteLine(f, par.ofmacedu, ofmaceduVal, " ofmac edu", total, vat);
			WriteLine(f, par.odf, odfVal, " odf", total, vat);
			(* write vat *)
			IF par.vat THEN
				f.WriteLn;
				INC(total, (vat * vatVal) DIV 1000);	(* vat is 6.5% *)
				f.WriteString("value added tax (");
				f.WriteInt(vatVal DIV 10); f.WriteChar("."); f.WriteInt(vatVal MOD 10);
				f.WriteString("% on ");
				f.WriteInt(vat DIV 100); f.WriteChar("."); f.WriteIntForm(vat MOD 100, 10, 2, "0", FALSE);
				f.WriteString(")");
				f.WriteTab;
				f.WriteIntForm((vat * vatVal) DIV 100000, 10, 5, TextModels.digitspace, FALSE);
				f.WriteChar("."); f.WriteIntForm(((vat * vatVal) DIV 1000) MOD 100, 10, 2, "0", FALSE);
				f.WriteLn
			END;
			(* write total *)
			f.WriteLn;
			f.WriteString("Total"); f.WriteTab;
			f.WriteIntForm(total DIV 100, 10, 5, TextModels.digitspace, FALSE);
			f.WriteChar("."); f.WriteIntForm(total MOD 100, 10, 2, "0", FALSE);
			f.WriteString(" sFr.");
			f.WriteLn; f.WriteLn; f.WriteLn; f.WriteLn; f.WriteLn;
			f.WriteLn; f.WriteLn; f.WriteLn; f.WriteLn;
			f.WriteString("The exporter of the products covered by this document declares that, except where otherwise clearly indicated, these products are of Swiss preferential origin.");
			f.WriteLn;
			Views.OpenAux(v, "Invoice")
		END
	END Invoice;

BEGIN
	NEW(root); Init
END ObxOrders.